diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 18d81d265..a871a603b 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -19,6 +19,6 @@ jobs: - uses: actions/checkout@v3 - run: ./script/setup.sh --all - run: cmake -B build -DCMAKE_BUILD_TYPE=${{ matrix.configuration }} - - run: cmake --build build --target safe-install.deb + - run: cmake --build build --target develop - run: cmake -B example/build -S example -DCMAKE_BUILD_TYPE=${{ matrix.configuration }} - - run: cmake --build example/build --target demo + - run: cmake --build example/build --target develop diff --git a/CMakeLists.txt b/CMakeLists.txt index b2c6ad40e..9323d8cbf 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -39,14 +39,6 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_INSTALL_B # ---- Configure --------------------------------------------------------------- -if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/.git) - execute_process(COMMAND git rev-parse HEAD - COMMAND tr -d "\n" - OUTPUT_VARIABLE ${PROJECT_NAME}_VERSION_EXACT) -else() - set(${PROJECT_NAME}_VERSION_EXACT "") -endif() - include(TestBigEndian) TEST_BIG_ENDIAN(IS_BIG_ENDIAN) # Use CMAKE_CXX_BYTE_ORDER if CMake >= 3.20 @@ -87,8 +79,7 @@ target_include_directories(kernel PUBLIC $ $) -target_link_libraries(kernel PRIVATE stdc++fs - PRIVATE ${CMAKE_DL_LIBS} +target_link_libraries(kernel PRIVATE ${CMAKE_DL_LIBS} PUBLIC gmp) set_target_properties(kernel PROPERTIES OUTPUT_NAME ${PROJECT_NAME} # Rename libkernel => libmeevax @@ -156,15 +147,20 @@ include(CPack) enable_testing() +find_program(${PROJECT_NAME}_MEMORY_CHECK_COMMAND valgrind) + +set(${PROJECT_NAME}_MEMORY_CHECK_COMMAND_OPTIONS --error-exitcode=1 # = EXIT_FAILURE) + --leak-check=full + --quiet + --show-leak-kinds=all) + file(GLOB ${PROJECT_NAME}_TEST_SS ${CMAKE_CURRENT_SOURCE_DIR}/test/*.ss) foreach(EACH IN LISTS ${PROJECT_NAME}_TEST_SS) get_filename_component(FILENAME ${EACH} NAME_WE) add_test(NAME ${FILENAME} - COMMAND valgrind --error-exitcode=1 # = EXIT_FAILURE - --leak-check=full - --quiet - --show-leak-kinds=all + COMMAND ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND} + ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND_OPTIONS} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/meevax ${EACH}) endforeach() @@ -176,24 +172,22 @@ foreach(EACH IN LISTS ${PROJECT_NAME}_TEST_CPP) add_executable(assert-${FILENAME} ${EACH}) target_link_libraries(assert-${FILENAME} PRIVATE kernel) add_test(NAME assert-${FILENAME} - COMMAND valgrind --error-exitcode=1 # = EXIT_FAILURE - --leak-check=full - --quiet - --show-leak-kinds=all + COMMAND ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND} + ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND_OPTIONS} ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/assert-${FILENAME}) endforeach() # ---- Additional Targets ------------------------------------------------------ -execute_process(COMMAND nproc OUTPUT_VARIABLE NPROC) +execute_process(COMMAND nproc OUTPUT_VARIABLE ${PROJECT_NAME}_NPROC) add_custom_target(install.deb - COMMAND make -j ${NPROC} - COMMAND ${CMAKE_CPACK_COMMAND} + COMMAND ${CMAKE_MAKE_PROGRAM} -j${${PROJECT_NAME}_NPROC} + COMMAND ${CMAKE_MAKE_PROGRAM} package COMMAND sudo apt install ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}_${PROJECT_VERSION}_amd64.deb) -add_custom_target(safe-install.deb - COMMAND make -j ${NPROC} - COMMAND ${CMAKE_CTEST_COMMAND} -j ${NPROC} - COMMAND ${CMAKE_CPACK_COMMAND} +add_custom_target(develop + COMMAND ${CMAKE_MAKE_PROGRAM} -j${${PROJECT_NAME}_NPROC} + COMMAND ${CMAKE_MAKE_PROGRAM} test ARGS=-j${${PROJECT_NAME}_NPROC} + COMMAND ${CMAKE_MAKE_PROGRAM} package COMMAND sudo apt install ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}_${PROJECT_VERSION}_amd64.deb) diff --git a/README.md b/README.md index 9c5219fc7..444dd1d9e 100644 --- a/README.md +++ b/README.md @@ -3,26 +3,37 @@
A programmable programming lanugage.

-
+

- Overview  |  - Requirements  |  - Installation  |  - Usage  |  - License  |  - References + + Overview + +  |  + + Installation + +  |  + + Usage + +  |  + + License + +  |  + + References +

## Overview > Programming languages should be designed not by piling feature on top of feature, but by removing the weaknesses and restrictions that make additional features appear necessary. ->
-> Revised7 Report on the Algorithmic Language Scheme [1] ->
+>
Revised7 Report on the Algorithmic Language Scheme [1]
Meevax is an implementation of Lisp-1 programming language, supporting subset of the [Scheme](http://www.scheme-reports.org/) (R7RS) and [SRFI](https://srfi.schemers.org/)s. @@ -45,12 +56,14 @@ Subset of R7RS-small. |--------------------------------------------------------:|:-------------------------------------------------------|:------------------------------------------------------|:------------------| | [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | | [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | +| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | | [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | | [ 9](https://srfi.schemers.org/srfi-9/srfi-9.html) | Defining Record Types | [`(srfi 9)`](./basis/srfi-9.ss) | R7RS 5.5 | | [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | | | | [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss) | R7RS 4.2.2 | | [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss) | R7RS 6.11 | | [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | | R7RS 2.2 | +| [ 31](https://srfi.schemers.org/srfi-31/srfi-31.html) | A special form rec for recursive evaluation | [`(srfi 31)`](./basis/srfi-31.ss) | | | [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss) | R7RS 6.11 | | [ 38](https://srfi.schemers.org/srfi-38/srfi-38.html) | External Representation for Data With Shared Structure | [`(srfi 38)`](./basis/srfi-38.ss) | R7RS 6.13.3 | | [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss) | R7RS 4.2.6 | @@ -58,12 +71,12 @@ Subset of R7RS-small. | [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | | R7RS 2.2 | | [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | [`(srfi 78)`](./basis/srfi-78.ss) | Except `check-ec` | | [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | | R7RS 4.2.1 | +| [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html) | An interface to access environment variables | [`(srfi 98)`](./basis/srfi-98.ss) | R7RS 6.14 | | [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2 | -| [211](https://srfi.schemers.org/srfi-211/srfi-211.html) | Scheme Macro Libraries | [`(srfi 211 explicit-renaming)`](./basis/srfi-211.ss) | | -## Requirements +## Installation -### Software +### Requirements - [GCC](https://gcc.gnu.org/) (>= 9.4.0) or [Clang](https://clang.llvm.org/) (>= 11.0.0) - [CMake](https://cmake.org/) (>= 3.16.3) @@ -71,50 +84,53 @@ Subset of R7RS-small. - [GNU Binutils](https://www.gnu.org/software/binutils/) - [GNU Multiple Precision Arithmetic Library (GMP)](https://gmplib.org/) -To install the above software, it is easy to use the following script. +### Install ``` bash -$ ./script/setup.sh +cmake -B build -DCMAKE_BUILD_TYPE=Release +cd build +make install.deb ``` -## Installation - -### Install +or ``` bash -$ cmake -B build -DCMAKE_BUILD_TYPE=Release -$ cd build -$ make install.deb +cmake -B build -DCMAKE_BUILD_TYPE=Release +cd build +make install ``` ### Uninstall +If you installed with `make install.deb`, + ``` bash -$ sudo apt remove meevax +sudo apt remove meevax +``` + +or if you installed with `make install`, + +``` bash +sudo rm -rf /usr/local/bin/meevax +sudo rm -rf /usr/local/include/meevax +sudo rm -rf /usr/local/lib/libmeevax* +sudo rm -rf /usr/local/share/meevax ``` ### CMake targets | Target Name | Description |--------------------|--- -| `all` (default) | Build shared-library `libmeevax.0.4.597.so` and executable `meevax`. -| `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.4.597_amd64.deb`. -| `install` | Copy files into `/usr/local` __(1)__. +| `all` (default) | Build shared-library `libmeevax.0.4.653.so` and executable `meevax` +| `test` | Test executable `meevax` +| `package` | Generate debian package `meevax_0.4.653_amd64.deb` +| `install` | Copy files into `/usr/local` | `install.deb` | `all` + `package` + `sudo apt install .deb` -| `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` - -__(1)__ Meevax installed by `make install` cannot be uninstalled by the system's package manager (for example, `apt remove meevax`). You need to manually delete the following files to uninstall: - -- `/usr/local/bin/meevax` -- `/usr/local/include/meevax` -- `/usr/local/lib/libmeevax*` -- `/usr/local/share/meevax` ## Usage ``` -Meevax Lisp 0.4.597 +Meevax Lisp 0.4.653 Usage: meevax [option...] [file...] @@ -129,13 +145,6 @@ Options: ``` -| Example | Effects | -|:-------------------------------------------|:--| -| `$ meevax -i` | Start interactive session. You can exit the session by input `(exit)` or Ctrl+C or Ctrl+D. -| `$ meevax foo.ss` | Evaluate a script `foo.ss`. | -| `$ meevax -e '(+ 1 2 3)'` | Display `6`. -| `$ meevax -e "(define home \"$HOME\")" -i` | Define value of shell-environment variable `$HOME` as string typed Scheme variable `home`, and then start interactive session on environment includes the variable `home`. - ## License See [LICENSE](./LICENSE). @@ -146,5 +155,6 @@ See [LICENSE](./LICENSE). ### Resources -* [TinyScheme](http://tinyscheme.sourceforge.net/) +* [Chibi-Scheme](https://github.com/ashinn/chibi-scheme) * [SECDR-Scheme](http://www.maroon.dti.ne.jp/nagar17/mulasame/) +* [TinyScheme](http://tinyscheme.sourceforge.net/) diff --git a/VERSION b/VERSION index 20975a8bb..e4b7959f1 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.4.597 +0.4.653 diff --git a/basis/meevax.ss b/basis/meevax.ss new file mode 100644 index 000000000..d883dff98 --- /dev/null +++ b/basis/meevax.ss @@ -0,0 +1,107 @@ +(define-library (meevax macro-transformer) + (import (only (meevax comparator) eq? eqv?) + (only (meevax core) begin define if lambda quote set!) + (only (meevax list) null?) + (only (meevax macro) identifier? syntactic-closure? make-syntactic-closure) + (only (meevax pair) cons car cdr caar cdar)) + + (export make-syntactic-closure + identifier? + identifier=? + sc-macro-transformer + rsc-macro-transformer + er-macro-transformer) + + (begin (define (sc-macro-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure mac-env '() (f form use-env)))) + + (define (rsc-macro-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure use-env '() (f form mac-env)))) + + (define (assq x alist) + (if (null? alist) + #f + (if (eq? x (caar alist)) + (car alist) + (assq x (cdr alist))))) + + (define (identifier=? environment1 identifier1 + environment2 identifier2) + (eqv? (if (syntactic-closure? identifier1) identifier1 (make-syntactic-closure environment1 '() identifier1)) + (if (syntactic-closure? identifier2) identifier2 (make-syntactic-closure environment2 '() identifier2)))) + + (define (er-macro-transformer f) + (lambda (form use-env mac-env) + (define cache '()) + (f form + (lambda (x) + ((lambda (pare) + (if pare + (cdr pare) + (begin (set! cache (cons (cons x (make-syntactic-closure mac-env '() x)) + cache)) + (cdar cache)))) + (assq x cache))) + (lambda (x y) + (identifier=? use-env x use-env y))))))) + +(define-library (meevax continuation) + (import (only (meevax context) emergency-exit) + (only (meevax comparator) eq?) + (only (meevax core) begin call-with-current-continuation! current define if install lambda) + (only (meevax pair) caar car cdar cdr cons pair?) + (only (meevax list) null?)) + + (export call-with-current-continuation dynamic-wind exit) + + (begin (define (current-dynamic-extents) + (current 0)) + + (define (install-dynamic-extents! extents) + (install 0 extents)) + + (define (dynamic-wind before thunk after) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html + (before) + (install-dynamic-extents! (cons (cons before after) + (current-dynamic-extents))) + ((lambda (result) ; TODO let-values + (install-dynamic-extents! (cdr (current-dynamic-extents))) + (after) + result) ; TODO (apply values result) + (thunk))) + + (define (call-with-current-continuation procedure) + (define (windup! from to) + (install-dynamic-extents! from) + (if (eq? from to) + #t + (if (null? from) + (begin (windup! from (cdr to)) + ((caar to))) + (if (null? to) + (begin ((cdar from)) + (windup! (cdr from) to)) + (begin ((cdar from)) + (windup! (cdr from) + (cdr to)) + ((caar to)))))) + (install-dynamic-extents! to)) + ((lambda (dynamic-extents) + (call-with-current-continuation! + (lambda (continue) + (procedure (lambda (x) + (windup! (current-dynamic-extents) dynamic-extents) + (continue x)))))) + (current-dynamic-extents))) + + (define (exit . xs) + (letrec ((for-each (lambda (f x) + (if (pair? x) + (begin (f (car x)) + (for-each f (cdr x))))))) + (for-each (lambda (before/after) + ((cdr before/after))) + (current-dynamic-extents)) + (emergency-exit . xs))))) diff --git a/basis/r4rs-essential.ss b/basis/r4rs-essential.ss index 0f8e2b1c7..4756c1c93 100644 --- a/basis/r4rs-essential.ss +++ b/basis/r4rs-essential.ss @@ -2,10 +2,12 @@ (import (meevax character) (meevax core) (meevax comparator) + (meevax continuation) (rename (meevax environment) (load %load)) (meevax function) (meevax list) + (only (meevax macro-transformer) er-macro-transformer identifier?) (meevax number) (meevax pair) (meevax port) @@ -15,32 +17,32 @@ (meevax symbol) (meevax vector) (rename (meevax write) - (write %write)) - (srfi 211 explicit-renaming)) + (write %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) + 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) (begin (define (list . xs) xs) @@ -318,7 +320,7 @@ (define (exact? z) (define (exact-complex? x) - (and (%complex? x) + (and (imaginary? x) (exact? (real-part x)) (exact? (imag-part x)))) (or (exact-complex? z) @@ -327,7 +329,7 @@ (define (inexact? z) (define (inexact-complex? x) - (and (%complex? x) + (and (imaginary? x) (or (inexact? (real-part x)) (inexact? (imag-part x))))) (define (floating-point? z) @@ -496,16 +498,9 @@ (list->string xs)) (define (string-map f x . xs) ; r7rs - (define (string-map-1 x) - (list->string - (map f (string->list x)))) - (define (string-map-n xs) - (map list->string - (map (lambda (c) (map f c)) - (map string->list xs)))) (if (null? xs) - (string-map-1 x) - (string-map-n (cons x 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)) @@ -542,9 +537,6 @@ (begin (apply map f x xs) (if #f #f)))) - (define (call-with-current-continuation f) - (call-with-current-continuation! f)) - (define (call-with-input-file path f) ; r7rs incompatible (values unsupported) (define (call-with-input-port port f) (let ((result (f port))) diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 3130da404..16a1040f8 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -1,14 +1,14 @@ (define-library (scheme r4rs) (import (meevax inexact) (only (meevax core) define-syntax) + (only (meevax macro-transformer) er-macro-transformer) (only (meevax number) exact-integer? expt exact inexact ratio? ratio-numerator ratio-denominator) (only (meevax port) input-port output-port) (only (meevax read) get-ready?) (only (meevax string) string-copy) (only (meevax vector) vector-fill!) (scheme r4rs essential) - (srfi 45) - (srfi 211 explicit-renaming)) + (srfi 45)) (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 @@ -16,29 +16,29 @@ cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list length append reverse list-tail list-ref memq memv member - assq assv assoc symbol? symbol->string string->symbol 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 rationalize - exp log sin cos tan asin acos atan sqrt expt make-rectangular - make-polar real-part imag-part magnitude angle + 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 numerator denominator floor ceiling truncate round + rationalize exp log sin cos tan asin acos atan sqrt expt + make-rectangular make-polar real-part imag-part magnitude angle (rename inexact exact->inexact) (rename exact inexact->exact) 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 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) + 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) (begin (define-syntax let* (er-macro-transformer @@ -108,10 +108,10 @@ (* radius (sin phi)))) (define (real-part z) - (if (%complex? z) (car z) z)) + (if (imaginary? z) (car z) z)) (define (imag-part z) - (if (%complex? z) (cdr z) 0)) + (if (imaginary? z) (cdr z) 0)) (define (magnitude z) (sqrt (+ (square (real-part z)) diff --git a/basis/r5rs.ss b/basis/r5rs.ss index 610342c8b..3950fd30e 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -1,54 +1,8 @@ -(define-library (scheme r5rs continuation) - (import (meevax context) - (only (meevax core) call-with-current-continuation! current define-syntax install) - (except (scheme r4rs) call-with-current-continuation)) - - (export call-with-current-continuation dynamic-wind exit) - - ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html - - (begin (define (current-dynamic-extents) - (current 0)) - - (define (install-dynamic-extents! extents) - (install 0 extents)) - - (define (dynamic-wind before thunk after) - (before) - (install-dynamic-extents! (cons (cons before after) - (current-dynamic-extents))) - ((lambda (result) ; TODO let-values - (install-dynamic-extents! (cdr (current-dynamic-extents))) - (after) - result) ; TODO (apply values result) - (thunk))) - - (define (call-with-current-continuation procedure) - (define (windup! from to) - (install-dynamic-extents! from) - (cond ((eq? from to)) - ((null? from) (windup! from (cdr to)) ((caar to))) - ((null? to) ((cdar from)) (windup! (cdr from) to)) - (else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to)))) - (install-dynamic-extents! to)) - (let ((dynamic-extents (current-dynamic-extents))) - (call-with-current-continuation! - (lambda (continue) - (procedure (lambda (x) - (windup! (current-dynamic-extents) dynamic-extents) - (continue x))))))) - - (define (exit . normally?) - (for-each (lambda (before/after) - ((cdr before/after))) - (current-dynamic-extents)) - (apply emergency-exit normally?)))) - (define-library (scheme r5rs) - (import (only (meevax core) define-syntax let-syntax letrec-syntax) + (import (only (meevax continuation) dynamic-wind) + (only (meevax core) define-syntax let-syntax letrec-syntax) (only (meevax environment) environment eval) - (except (scheme r4rs) call-with-current-continuation) - (except (scheme r5rs continuation) exit) + (scheme r4rs) (srfi 149)) (export quote lambda if set! cond case and or let let* letrec begin do delay @@ -71,9 +25,9 @@ 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 + string->list list->string string-copy string-fill! vector? + make-vector vector vector-length vector-ref vector-set! vector->list + list->vector vector-fill! procedure? apply map for-each force call-with-current-continuation values call-with-values dynamic-wind eval scheme-report-environment null-environment interaction-environment call-with-input-file call-with-output-file diff --git a/basis/r7rs.ss b/basis/r7rs.ss index a4ef8d7b7..8e7213950 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -1,10 +1,12 @@ (define-library (scheme base) (import (only (meevax error) error-object? read-error? file-error?) + (only (meevax macro-transformer) er-macro-transformer) (only (meevax number) exact-integer? exact-integer-square-root) - (only (meevax vector) vector-append vector-copy vector-copy! string->vector) (only (meevax port) binary-port? textual-port? port? input-port open? output-port flush error-port eof-object) (only (meevax read) get-char get-char! get-ready?) (only (meevax string) string-copy! vector->string) + (only (meevax vector homogeneous) u8vector? make-u8vector u8vector u8vector-length u8vector-ref u8vector-set! u8vector-copy u8vector-copy! u8vector-append u8vector->string string->u8vector) + (only (meevax vector) vector-append vector-copy vector-copy! string->vector) (only (meevax version) features) (only (meevax write) put-char put-string) (scheme r5rs) @@ -13,18 +15,16 @@ (srfi 11) (srfi 23) (srfi 34) - (srfi 39) - (srfi 211 explicit-renaming)) + (srfi 39)) (export ; 4.1. Primitive expression types quote lambda if set! - ; include - ; include-ci + ; include include-ci cond else => case and or when unless ; cond-expand - let let* letrec letrec* let-values let*-values begin do make-parameter - parameterize guard quasiquote unquote unquote-splicing let-syntax - letrec-syntax syntax-rules _ ... syntax-error + let let* letrec letrec* let-values let*-values begin do + make-parameter parameterize guard quasiquote unquote unquote-splicing + let-syntax letrec-syntax syntax-rules _ ... syntax-error ; 5.3. Variable definitions define define-values define-syntax define-record-type @@ -36,28 +36,31 @@ number? complex? real? rational? integer? exact? inexact? exact-integer? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs floor/ floor-quotient floor-remainder truncate/ - truncate-quotient truncate-remainder quotient remainder modulo gcd lcm - numerator denominator floor ceiling truncate round rationalize square - exact-integer-sqrt expt inexact exact number->string string->number + truncate-quotient truncate-remainder quotient remainder modulo gcd + lcm numerator denominator floor ceiling truncate round rationalize + square exact-integer-sqrt expt inexact exact number->string + string->number ; 6.3. Booleans not boolean? boolean=? ; 6.4. Pairs and lists pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr null? list? - make-list list length append reverse list-tail list-ref list-set! memq - memv member assq assv assoc list-copy + make-list list length append reverse list-tail list-ref list-set! + memq memv member assq assv assoc list-copy ; 6.5. Symbols symbol? symbol=? symbol->string string->symbol ; 6.6. Characters - char? char=? char? char<=? char>=? char->integer integer->char + char? char=? char? char<=? char>=? char->integer + integer->char ; 6.7. Strings string? make-string string string-length string-ref string-set! - string=? string>? string=? substring string-append - string->list list->string string-copy string-copy! string-fill! + string=? string>? string=? substring + string-append string->list list->string string-copy string-copy! + string-fill! ; 6.8. Vectors vector? make-vector vector vector-length vector-ref vector-set! @@ -65,24 +68,13 @@ vector-copy! vector-append vector-fill! ; 6.9. Bytevectors - ; bytevector? - ; make-bytevector - ; bytevector - ; bytevector-length - ; bytevector-u8-ref - ; bytevector-u8-set! - ; bytevector-copy - ; bytevector-copy! - ; bytevector-append - ; utf8->string - ; string->utf8 + bytevector? make-bytevector bytevector bytevector-length + bytevector-u8-ref bytevector-u8-set! bytevector-copy bytevector-copy! + bytevector-append utf8->string string->utf8 ; 6.10. Control features - procedure? apply map string-map - ; vector-map - for-each - ; string-for-each - ; vector-for-each + procedure? apply map string-map vector-map for-each + ; string-for-each vector-for-each call-with-current-continuation call/cc values call-with-values dynamic-wind @@ -96,21 +88,14 @@ current-output-port current-error-port close-port close-input-port close-output-port open-input-string open-output-string get-output-string - ; open-input-bytevector - ; open-output-bytevector - ; get-output-bytevector + ; open-input-bytevector open-output-bytevector get-output-bytevector read-char peek-char ; read-line eof-object? eof-object char-ready? - ; read-string - ; read-u8 - ; peek-u8 - ; u8-ready? - ; read-bytevector + ; read-string read-u8 peek-u8 u8-ready? read-bytevector ; read-bytevector! newline write-char write-string - ; write-u8 - ; write-bytevector + ; write-u8 write-bytevector flush-output-port ; 6.14. System interface @@ -224,17 +209,37 @@ (define symbol=? eqv?) + (define bytevector? u8vector?) + + (define make-bytevector make-u8vector) + + (define bytevector u8vector) + + (define bytevector-length u8vector-length) + + (define bytevector-u8-ref u8vector-ref) + + (define bytevector-u8-set! u8vector-set!) + + (define bytevector-copy u8vector-copy) + + (define bytevector-copy! u8vector-copy!) + + (define bytevector-append u8vector-append) + + (define utf8->string u8vector->string) + + (define string->utf8 string->u8vector) + (define (string-map f x . xs) - (define (string-map-1 x) - (list->string - (map f (string->list x)))) - (define (string-map-n xs) - (map list->string - (map (lambda (c) (map f c)) - (map string->list xs)))) (if (null? xs) - (string-map-1 x) - (string-map-n (cons x xs)))) + (list->string (map f (string->list x))) + (list->string (apply map f (map string->list (cons x xs)))))) + + (define (vector-map f x . xs) + (if (null? xs) + (list->vector (map f (vector->list x))) + (list->vector (apply map f (map vector->list (cons x xs)))))) (define call/cc call-with-current-continuation) @@ -510,16 +515,14 @@ (export load)) (define-library (scheme process-context) - (import (meevax context) - (scheme r5rs continuation) - ) - (export ; command-line + (import (only (meevax context) command-line emergency-exit) + (only (meevax continuation) exit) + (srfi 98)) + (export command-line exit emergency-exit - ; get-environment-variable - ; get-environment-variables - ) - ) + get-environment-variable + get-environment-variables)) (define-library (scheme time) (export current-second diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index 91cbe72c5..d5d71bc1a 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -1,10 +1,10 @@ -; https://srfi.schemers.org/srfi-1/srfi-1.html -; -; Copyright (c) 1998, 1999 by Olin Shivers. -; -; You may do as you please with this code as long as you do not remove this -; copyright notice or hold me liable for its use. Please send bug reports to -; shivers@ai.mit.edu. -Olin +#| + Copyright (c) 1998, 1999 by Olin Shivers. + + You may do as you please with this code as long as you do not remove this + copyright notice or hold me liable for its use. Please send bug reports to + shivers@ai.mit.edu. -Olin +|# (define-library (srfi 1) (import (scheme base) diff --git a/basis/srfi-149.ss b/basis/srfi-149.ss index fba760e2f..5bc999ab4 100644 --- a/basis/srfi-149.ss +++ b/basis/srfi-149.ss @@ -1,33 +1,33 @@ -; 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. +#| + 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 (srfi 149) (import (only (meevax core) define-syntax quote-syntax) + (only (meevax macro-transformer) er-macro-transformer identifier?) (only (meevax symbol) identifier->symbol) - (scheme r4rs) - (srfi 211 explicit-renaming)) + (scheme r4rs)) (export syntax-rules) diff --git a/basis/srfi-211.ss b/basis/srfi-211.ss deleted file mode 100644 index f06075d3a..000000000 --- a/basis/srfi-211.ss +++ /dev/null @@ -1,45 +0,0 @@ -(define-library (srfi 211 syntactic-closures) - (import (meevax core) - (meevax macro)) - - (begin (define (sc-macro-transformer f) - (lambda (form use-env mac-env) - (make-syntactic-closure mac-env '() (f form use-env)))) - - (define (rsc-macro-transformer f) - (lambda (form use-env mac-env) - (make-syntactic-closure use-env '() (f form mac-env))))) - - (export sc-macro-transformer rsc-macro-transformer make-syntactic-closure identifier?)) - -(define-library (srfi 211 explicit-renaming) - (import (meevax comparator) - (meevax core) - (meevax list) - (meevax macro) - (meevax pair)) - - (begin (define (er-macro-transformer f) - (lambda (form use-env mac-env) - (define renames '()) - (define (rename x) - (letrec ((assq (lambda (x alist) - (if (null? alist) #f - (if (eq? x (caar alist)) - (car alist) - (assq x (cdr alist)))))) - (alist-cons (lambda (key x alist) - (cons (cons key x) alist)))) - (define key/value (assq x renames)) - (if key/value - (cdr key/value) - (begin (set! renames (alist-cons x (make-syntactic-closure mac-env '() x) renames)) - (cdar renames))))) - (define (compare x y) - (eqv? (if (syntactic-closure? x) x - (make-syntactic-closure use-env '() x)) - (if (syntactic-closure? y) y - (make-syntactic-closure use-env '() y)))) - (f form rename compare)))) - - (export er-macro-transformer identifier?)) diff --git a/basis/srfi-31.ss b/basis/srfi-31.ss new file mode 100644 index 000000000..ff72d7641 --- /dev/null +++ b/basis/srfi-31.ss @@ -0,0 +1,31 @@ +#| + Copyright (C) Dr. Mirko Luedde (2002). All Rights Reserved. + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. +|# + +(define-library (srfi 31) + (import (scheme base)) + (export rec) + (begin (define-syntax rec + (syntax-rules () + ((rec (name . variables) . body) + (letrec ((name (lambda variables . body))) name)) + ((rec name expression) + (letrec ((name expression)) name)))))) diff --git a/basis/srfi-34.ss b/basis/srfi-34.ss index 038590f59..f92271826 100644 --- a/basis/srfi-34.ss +++ b/basis/srfi-34.ss @@ -1,22 +1,24 @@ -; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved. -; -; Permission is hereby granted, free of charge, to any person obtaining a copy -; of this software and associated documentation files (the "Software"), to -; deal in the Software without restriction, including without limitation the -; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -; sell copies of the Software, and to permit persons to whom the Software is -; furnished to do so, subject to the following conditions: -; -; The above copyright notice and this permission notice shall be included in -; all copies or substantial portions of the Software. -; -; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -; IN THE SOFTWARE. +#| + Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved. + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. +|# (define-library (srfi 34) (import (only (meevax error) throw kernel-exception-handler-set!) diff --git a/basis/srfi-38.ss b/basis/srfi-38.ss index 2aff3a845..9edbe2397 100644 --- a/basis/srfi-38.ss +++ b/basis/srfi-38.ss @@ -1,22 +1,24 @@ -; Copyright (C) Ray Dillinger 2003. All Rights Reserved. -; -; Permission is hereby granted, free of charge, to any person obtaining a copy -; of this software and associated documentation files (the "Software"), to deal -; in the Software without restriction, including without limitation the rights -; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -; copies of the Software, and to permit persons to whom the Software is -; furnished to do so, subject to the following conditions: -; -; The above copyright notice and this permission notice shall be included in -; all copies or substantial portions of the Software. -; -; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -; THE SOFTWARE. +#| + Copyright (C) Ray Dillinger 2003. All Rights Reserved. + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. +|# (define-library (srfi 38) (import (scheme r5rs) diff --git a/basis/srfi-39.ss b/basis/srfi-39.ss index fd4697f8b..00e047a61 100644 --- a/basis/srfi-39.ss +++ b/basis/srfi-39.ss @@ -1,27 +1,29 @@ -; Copyright (C) Marc Feeley 2002. All Rights Reserved. -; -; Permission is hereby granted, free of charge, to any person obtaining a copy -; of this software and associated documentation files (the "Software"), to deal -; in the Software without restriction, including without limitation the rights -; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -; copies of the Software, and to permit persons to whom the Software is -; furnished to do so, subject to the following conditions: -; -; The above copyright notice and this permission notice shall be included in all -; copies or substantial portions of the Software. -; -; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -; SOFTWARE. +#| + Copyright (C) Marc Feeley 2002. All Rights Reserved. + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. +|# (define-library (srfi 39) (import (only (meevax core) current install) - (scheme r5rs) - (srfi 211 explicit-renaming)) + (only (meevax macro-transformer) er-macro-transformer) + (scheme r5rs)) (export make-parameter parameterize) diff --git a/basis/srfi-4.ss b/basis/srfi-4.ss new file mode 100644 index 000000000..0fe6465ac --- /dev/null +++ b/basis/srfi-4.ss @@ -0,0 +1,32 @@ +(define-library (srfi 4) + (import (meevax vector homogeneous)) + (export + f32vector? make-f32vector f32vector f32vector-length f32vector-ref + f32vector-set! f32vector->list list->f32vector + + f64vector? make-f64vector f64vector f64vector-length f64vector-ref + f64vector-set! f64vector->list list->f64vector + + s8vector? make-s8vector s8vector s8vector-length s8vector-ref + s8vector-set! s8vector->list list->s8vector + + s16vector? make-s16vector s16vector s16vector-length s16vector-ref + s16vector-set! s16vector->list list->s16vector + + s32vector? make-s32vector s32vector s32vector-length s32vector-ref + s32vector-set! s32vector->list list->s32vector + + s64vector? make-s64vector s64vector s64vector-length s64vector-ref + s64vector-set! s64vector->list list->s64vector + + u8vector? make-u8vector u8vector u8vector-length u8vector-ref + u8vector-set! u8vector->list list->u8vector + + u16vector? make-u16vector u16vector u16vector-length u16vector-ref + u16vector-set! u16vector->list list->u16vector + + u32vector? make-u32vector u32vector u32vector-length u32vector-ref + u32vector-set! u32vector->list list->u32vector + + u64vector? make-u64vector u64vector u64vector-length u64vector-ref + u64vector-set! u64vector->list list->u64vector)) diff --git a/basis/srfi-45.ss b/basis/srfi-45.ss index d3f2ce071..6e07b5634 100644 --- a/basis/srfi-45.ss +++ b/basis/srfi-45.ss @@ -1,7 +1,7 @@ (define-library (srfi 45) ; Based on r7rs reference implementation. - (import (scheme r4rs essential) - (only (meevax core) define-syntax) - (srfi 211 explicit-renaming)) + (import (only (meevax core) define-syntax) + (only (meevax macro-transformer) er-macro-transformer) + (scheme r4rs essential)) (export delay eager force lazy promise?) diff --git a/basis/srfi-78.ss b/basis/srfi-78.ss index 780fd3133..f70cd5876 100644 --- a/basis/srfi-78.ss +++ b/basis/srfi-78.ss @@ -1,23 +1,23 @@ #| Copyright (C) Sebastian Egner (2005-2006). All Rights Reserved. - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation - the rights to use, copy, modify, merge, publish, distribute, sublicense, - and/or sell copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER - DEALINGS IN THE SOFTWARE. + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. |# (define-library (srfi 78) diff --git a/basis/srfi-8.ss b/basis/srfi-8.ss index a7522b28f..4303a77c0 100644 --- a/basis/srfi-8.ss +++ b/basis/srfi-8.ss @@ -1,23 +1,23 @@ #| Copyright (C) John David Stone (1999). All Rights Reserved. - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation - the rights to use, copy, modify, merge, publish, distribute, sublicense, - and/or sell copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER - DEALINGS IN THE SOFTWARE. + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. |# (define-library (srfi 8) diff --git a/basis/srfi-9.ss b/basis/srfi-9.ss index cc4b9c8b3..136d905c1 100644 --- a/basis/srfi-9.ss +++ b/basis/srfi-9.ss @@ -1,23 +1,23 @@ #| Copyright (C) Richard Kelsey (1999). All Rights Reserved. - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation - the rights to use, copy, modify, merge, publish, distribute, sublicense, - and/or sell copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER - DEALINGS IN THE SOFTWARE. + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. |# (define-library (srfi 9) diff --git a/basis/srfi-98.ss b/basis/srfi-98.ss new file mode 100644 index 000000000..57af949b0 --- /dev/null +++ b/basis/srfi-98.ss @@ -0,0 +1,4 @@ +(define-library (srfi 98) + (import (meevax system)) + (export get-environment-variable + get-environment-variables)) diff --git a/configure/README.md b/configure/README.md index a5c15bbdb..359605361 100644 --- a/configure/README.md +++ b/configure/README.md @@ -3,26 +3,37 @@
A programmable programming lanugage.

-
+

- Overview  |  - Requirements  |  - Installation  |  - Usage  |  - License  |  - References + + Overview + +  |  + + Installation + +  |  + + Usage + +  |  + + License + +  |  + + References +

## Overview > Programming languages should be designed not by piling feature on top of feature, but by removing the weaknesses and restrictions that make additional features appear necessary. ->
-> Revised7 Report on the Algorithmic Language Scheme [1] ->
+>
Revised7 Report on the Algorithmic Language Scheme [1]
Meevax is an implementation of Lisp-1 programming language, supporting subset of the [Scheme](http://www.scheme-reports.org/) (R7RS) and [SRFI](https://srfi.schemers.org/)s. @@ -45,12 +56,14 @@ Subset of R7RS-small. |--------------------------------------------------------:|:-------------------------------------------------------|:------------------------------------------------------|:------------------| | [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | | [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | +| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | | [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | | [ 9](https://srfi.schemers.org/srfi-9/srfi-9.html) | Defining Record Types | [`(srfi 9)`](./basis/srfi-9.ss) | R7RS 5.5 | | [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | | | | [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss) | R7RS 4.2.2 | | [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss) | R7RS 6.11 | | [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | | R7RS 2.2 | +| [ 31](https://srfi.schemers.org/srfi-31/srfi-31.html) | A special form rec for recursive evaluation | [`(srfi 31)`](./basis/srfi-31.ss) | | | [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss) | R7RS 6.11 | | [ 38](https://srfi.schemers.org/srfi-38/srfi-38.html) | External Representation for Data With Shared Structure | [`(srfi 38)`](./basis/srfi-38.ss) | R7RS 6.13.3 | | [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss) | R7RS 4.2.6 | @@ -58,12 +71,12 @@ Subset of R7RS-small. | [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | | R7RS 2.2 | | [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | [`(srfi 78)`](./basis/srfi-78.ss) | Except `check-ec` | | [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | | R7RS 4.2.1 | +| [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html) | An interface to access environment variables | [`(srfi 98)`](./basis/srfi-98.ss) | R7RS 6.14 | | [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2 | -| [211](https://srfi.schemers.org/srfi-211/srfi-211.html) | Scheme Macro Libraries | [`(srfi 211 explicit-renaming)`](./basis/srfi-211.ss) | | -## Requirements +## Installation -### Software +### Requirements - [GCC](https://gcc.gnu.org/) (>= 9.4.0) or [Clang](https://clang.llvm.org/) (>= 11.0.0) - [CMake](https://cmake.org/) (>= ${CMAKE_MINIMUM_REQUIRED_VERSION}) @@ -71,45 +84,48 @@ Subset of R7RS-small. - [GNU Binutils](https://www.gnu.org/software/binutils/) - [GNU Multiple Precision Arithmetic Library (GMP)](https://gmplib.org/) -To install the above software, it is easy to use the following script. +### Install ``` bash -$ ./script/setup.sh +cmake -B build -DCMAKE_BUILD_TYPE=Release +cd build +make install.deb ``` -## Installation - -### Install +or ``` bash -$ cmake -B build -DCMAKE_BUILD_TYPE=Release -$ cd build -$ make install.deb +cmake -B build -DCMAKE_BUILD_TYPE=Release +cd build +make install ``` ### Uninstall +If you installed with `make install.deb`, + ``` bash -$ sudo apt remove meevax +sudo apt remove meevax +``` + +or if you installed with `make install`, + +``` bash +sudo rm -rf ${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_BINDIR}/${PROJECT_NAME} +sudo rm -rf ${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_INCLUDEDIR}/${PROJECT_NAME} +sudo rm -rf ${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_LIBDIR}/${CMAKE_SHARED_LIBRARY_PREFIX}${PROJECT_NAME}* +sudo rm -rf ${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME} ``` ### CMake targets | Target Name | Description |--------------------|--- -| `all` (default) | Build shared-library `libmeevax.${PROJECT_VERSION}.so` and executable `meevax`. -| `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_${PROJECT_VERSION}_amd64.deb`. -| `install` | Copy files into `/usr/local` __(1)__. +| `all` (default) | Build shared-library `libmeevax.${PROJECT_VERSION}.so` and executable `meevax` +| `test` | Test executable `meevax` +| `package` | Generate debian package `meevax_${PROJECT_VERSION}_amd64.deb` +| `install` | Copy files into `/usr/local` | `install.deb` | `all` + `package` + `sudo apt install .deb` -| `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` - -__(1)__ Meevax installed by `make install` cannot be uninstalled by the system's package manager (for example, `apt remove meevax`). You need to manually delete the following files to uninstall: - -- `${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_BINDIR}/${PROJECT_NAME}` -- `${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_INCLUDEDIR}/${PROJECT_NAME}` -- `${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_LIBDIR}/${CMAKE_SHARED_LIBRARY_PREFIX}${PROJECT_NAME}*` -- `${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}` ## Usage @@ -117,13 +133,6 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ${${PROJECT_NAME}_HELP_TEXT} ``` -| Example | Effects | -|:-------------------------------------------|:--| -| `$ meevax -i` | Start interactive session. You can exit the session by input `(exit)` or Ctrl+C or Ctrl+D. -| `$ meevax foo.ss` | Evaluate a script `foo.ss`. | -| `$ meevax -e '(+ 1 2 3)'` | Display `6`. -| `$ meevax -e "(define home \"$HOME\")" -i` | Define value of shell-environment variable `$HOME` as string typed Scheme variable `home`, and then start interactive session on environment includes the variable `home`. - ## License See [LICENSE](./LICENSE). @@ -134,5 +143,6 @@ See [LICENSE](./LICENSE). ### Resources -* [TinyScheme](http://tinyscheme.sourceforge.net/) +* [Chibi-Scheme](https://github.com/ashinn/chibi-scheme) * [SECDR-Scheme](http://www.maroon.dti.ne.jp/nagar17/mulasame/) +* [TinyScheme](http://tinyscheme.sourceforge.net/) diff --git a/configure/basis.cpp b/configure/basis.cpp index 353e36ca8..f0328455a 100644 --- a/configure/basis.cpp +++ b/configure/basis.cpp @@ -20,24 +20,30 @@ namespace meevax { inline namespace kernel { - script const basis = R"###( -${${PROJECT_NAME}_BASIS_r4rs.ss} -${${PROJECT_NAME}_BASIS_r4rs-essential.ss} -${${PROJECT_NAME}_BASIS_r5rs.ss} -${${PROJECT_NAME}_BASIS_r7rs.ss} -${${PROJECT_NAME}_BASIS_srfi-1.ss} -${${PROJECT_NAME}_BASIS_srfi-6.ss} -${${PROJECT_NAME}_BASIS_srfi-8.ss} -${${PROJECT_NAME}_BASIS_srfi-9.ss} -${${PROJECT_NAME}_BASIS_srfi-11.ss} -${${PROJECT_NAME}_BASIS_srfi-23.ss} -${${PROJECT_NAME}_BASIS_srfi-34.ss} -${${PROJECT_NAME}_BASIS_srfi-38.ss} -${${PROJECT_NAME}_BASIS_srfi-39.ss} -${${PROJECT_NAME}_BASIS_srfi-45.ss} -${${PROJECT_NAME}_BASIS_srfi-78.ss} -${${PROJECT_NAME}_BASIS_srfi-149.ss} -${${PROJECT_NAME}_BASIS_srfi-211.ss} -)###"; + auto basis() -> std::vector + { + return { + R"##(${${PROJECT_NAME}_BASIS_meevax.ss})##", + R"##(${${PROJECT_NAME}_BASIS_r4rs-essential.ss})##", + R"##(${${PROJECT_NAME}_BASIS_r4rs.ss})##", + R"##(${${PROJECT_NAME}_BASIS_r5rs.ss})##", + R"##(${${PROJECT_NAME}_BASIS_r7rs.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-1.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-4.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-6.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-8.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-9.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-11.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-23.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-31.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-34.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-38.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-39.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-45.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-78.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-98.ss})##", + R"##(${${PROJECT_NAME}_BASIS_srfi-149.ss})##", + }; + } } } diff --git a/configure/version.cpp b/configure/version.cpp index e6a5c06b1..7e6bd27ca 100644 --- a/configure/version.cpp +++ b/configure/version.cpp @@ -20,60 +20,35 @@ namespace meevax { inline namespace kernel { - auto version() -> object const& - { - let static const version = string_to_symbol("${PROJECT_VERSION}"); - return version; - } - - auto major_version() -> object const& - { - let static const version = make("${PROJECT_VERSION_MAJOR}"); - return version; - } - - auto minor_version() -> object const& - { - let static const version = make("${PROJECT_VERSION_MINOR}"); - return version; - } - - auto patch_version() -> object const& - { - let static const version = make("${PROJECT_VERSION_PATCH}"); - return version; - } - - auto exact_version() -> object const& + auto help() noexcept -> std::string_view { - let static const version = string_to_symbol("${${PROJECT_NAME}_VERSION_EXACT}"); - return version; + return R"(${${PROJECT_NAME}_HELP_TEXT})"; } auto features() -> object const& { let static const features = list( - string_to_symbol("r5rs"), - string_to_symbol("exact-closed"), - string_to_symbol("exact-complex"), - string_to_symbol("ieee-float"), - string_to_symbol("ratios"), - string_to_symbol("posix"), - string_to_symbol("${CMAKE_SYSTEM_NAME}"), - string_to_symbol("${CMAKE_SYSTEM_PROCESSOR}"), + make_symbol("r5rs"), + make_symbol("exact-closed"), + make_symbol("exact-complex"), + make_symbol("ieee-float"), + make_symbol("ratios"), + make_symbol("posix"), + make_symbol("${CMAKE_SYSTEM_NAME}"), + make_symbol("${CMAKE_SYSTEM_PROCESSOR}"), // TODO C memory model flags. - string_to_symbol("${${PROJECT_NAME}_BYTE_ORDER}"), - string_to_symbol("${PROJECT_NAME}"), // The name of this implementation. - string_to_symbol("${PROJECT_NAME}-${PROJECT_VERSION}") // The name and version of this implementation. + make_symbol("${${PROJECT_NAME}_BYTE_ORDER}"), + make_symbol("${PROJECT_NAME}"), // The name of this implementation. + make_symbol("${PROJECT_NAME}-${PROJECT_VERSION}") // The name and version of this implementation. ); return features; } - auto help() -> std::string const& + auto version() -> object const& { - std::string static const help = R"(${${PROJECT_NAME}_HELP_TEXT})"; - return help; + let static const version = make_symbol("${PROJECT_VERSION}"); + return version; } } // namespace kernel } // namespace meevax diff --git a/example/CMakeLists.txt b/example/CMakeLists.txt index 9f5d8c6cb..a8a6c8a7d 100644 --- a/example/CMakeLists.txt +++ b/example/CMakeLists.txt @@ -16,5 +16,5 @@ add_test(NAME ${PROJECT_NAME} COMMAND meevax ${PROJECT_NAME}.ss WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) -add_custom_target(demo COMMAND make - COMMAND ${CMAKE_CTEST_COMMAND}) +add_custom_target(develop COMMAND ${CMAKE_MAKE_PROGRAM} + COMMAND ${CMAKE_CTEST_COMMAND}) diff --git a/include/meevax/algorithm/for_each.hpp b/include/meevax/algorithm/for_each.hpp deleted file mode 100644 index b9d416af3..000000000 --- a/include/meevax/algorithm/for_each.hpp +++ /dev/null @@ -1,60 +0,0 @@ -/* - Copyright 2018-2023 Tatsuya Yamasaki. - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*/ - -#ifndef INCLUDED_MEEVAX_ALGORITHM_FOR_EACH_HPP -#define INCLUDED_MEEVAX_ALGORITHM_FOR_EACH_HPP - -#include - -namespace meevax -{ -inline namespace algorithm -{ - template - struct for_each - { - C const& container; - - std::ostream::char_type const* seperator; - - explicit constexpr for_each(C const& container, std::ostream::char_type const* seperator = " ") - : container { container } - , seperator { seperator } - {} - - auto operator ()(std::ostream & os) const -> decltype(auto) - { - auto const* p = ""; - - for (auto const& each : container) - { - os << p << each; - p = seperator; - } - - return os; - } - }; - - template - auto operator <<(std::ostream & os, for_each const& print) -> decltype(auto) - { - return print(os); - } -} // namespace algorithm -} // namespace meevax - -#endif // INCLUDED_MEEVAX_ALGORITHM_FOR_EACH_HPP diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index 4e053aa9b..d9808bb45 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -17,19 +17,13 @@ #ifndef INCLUDED_MEEVAX_KERNEL_BASIS_HPP #define INCLUDED_MEEVAX_KERNEL_BASIS_HPP -#include +#include namespace meevax { inline namespace kernel { - #if __cpp_lib_string_view - using script = std::string_view; - #else - using script = std::experimental::string_view; - #endif - - script extern const basis; + auto basis() -> std::vector; } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/configurator.hpp b/include/meevax/kernel/configurator.hpp index e26057916..21e5f7433 100644 --- a/include/meevax/kernel/configurator.hpp +++ b/include/meevax/kernel/configurator.hpp @@ -28,13 +28,8 @@ namespace meevax inline namespace kernel { template - class configurator + struct configurator { - friend Environment; - - configurator() - {} - struct option { std::regex const pattern; @@ -48,12 +43,18 @@ inline namespace kernel {} }; - public: bool interactive = false; + std::vector command_line; + auto configure(const int argc, char const* const* const argv) { - return configure({ argv + 1, argv + argc }); + for (auto i = 0; i < argc; ++i) + { + command_line.emplace_back(argv[i]); + } + + return configure(command_line); } auto configure(std::vector const& args) -> void @@ -138,7 +139,7 @@ inline namespace kernel std::vector expressions {}; - for (auto iter = std::begin(args); iter != std::end(args); ++iter) + for (auto iter = std::next(std::begin(args)); iter != std::end(args); ++iter) { static std::regex const pattern { R"(--(\w[-\w]+)(?:=(.*))?|-([\w]+))" }; diff --git a/include/meevax/kernel/dynamic_environment.hpp b/include/meevax/kernel/dynamic_environment.hpp index 2d66c34a8..38b210edb 100644 --- a/include/meevax/kernel/dynamic_environment.hpp +++ b/include/meevax/kernel/dynamic_environment.hpp @@ -20,15 +20,15 @@ #include #include #include +#include namespace meevax { inline namespace kernel { template - class dynamic_environment + struct dynamic_environment { - protected: /* The SECD machine, which in its original form was invented by Landin, derives its name from the designation of its four pricipal registers: @@ -71,7 +71,6 @@ inline namespace kernel */ let static inline raise = unit; - public: template auto apply(object const& f, Ts&&... xs) -> object { diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index 480d7101a..9a7b6867f 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -53,11 +53,11 @@ inline namespace kernel auto operator <<(std::ostream &, environment const&) -> std::ostream &; - extern template class configurator; + extern template struct configurator; - extern template class dynamic_environment; + extern template struct dynamic_environment; - extern template class reader; + extern template struct reader; extern template struct syntactic_environment; } // namespace kernel diff --git a/include/meevax/kernel/exact_integer.hpp b/include/meevax/kernel/exact_integer.hpp index 7124b6bd1..9fee207ba 100644 --- a/include/meevax/kernel/exact_integer.hpp +++ b/include/meevax/kernel/exact_integer.hpp @@ -39,11 +39,21 @@ inline namespace kernel explicit exact_integer(mpz_t const) noexcept; - explicit exact_integer(int); + explicit exact_integer(std::int8_t); - explicit exact_integer(signed long); + explicit exact_integer(std::int16_t); - explicit exact_integer(unsigned long); + explicit exact_integer(std::int32_t); + + explicit exact_integer(std::int64_t); + + explicit exact_integer(std::uint8_t); + + explicit exact_integer(std::uint16_t); + + explicit exact_integer(std::uint32_t); + + explicit exact_integer(std::uint64_t); explicit exact_integer(double); @@ -55,17 +65,27 @@ inline namespace kernel auto operator=(std::string const&) -> exact_integer &; - operator int() const; + explicit operator bool() const; + + operator std::int8_t() const; + + operator std::int16_t() const; + + operator std::int32_t() const; + + operator std::int64_t() const; - operator signed long() const; + operator std::uint8_t() const; - operator unsigned long() const; + operator std::uint16_t() const; + + operator std::uint32_t() const; + + operator std::uint64_t() const; explicit operator float() const; explicit operator double() const; - - explicit operator bool() const; }; auto operator ==(exact_integer const&, int const) -> bool; @@ -91,6 +111,21 @@ inline namespace kernel auto operator <<(std::ostream &, exact_integer const&) -> std::ostream &; + struct gmp_free + { + void (*free)(void *, std::size_t); + + explicit gmp_free() + { + mp_get_memory_functions(nullptr, nullptr, &free); + } + + auto operator ()(char * data) const -> void + { + free(static_cast(data), std::strlen(data) + 1); + } + }; + auto exact_integer_sqrt(exact_integer const&) -> std::tuple; let extern const e0, e1; // Frequently used exact-integer values. diff --git a/include/meevax/kernel/export_spec.hpp b/include/meevax/kernel/export_spec.hpp index 1548a4f23..ec48b45e3 100644 --- a/include/meevax/kernel/export_spec.hpp +++ b/include/meevax/kernel/export_spec.hpp @@ -23,7 +23,7 @@ namespace meevax { inline namespace kernel { - class library; + struct library; struct export_spec { diff --git a/include/meevax/kernel/heterogeneous.hpp b/include/meevax/kernel/heterogeneous.hpp index fc5f6b479..e5d633f18 100644 --- a/include/meevax/kernel/heterogeneous.hpp +++ b/include/meevax/kernel/heterogeneous.hpp @@ -22,11 +22,11 @@ #include #include #include -#include #include #include #include #include +#include #include namespace meevax diff --git a/include/meevax/kernel/homogeneous_vector.hpp b/include/meevax/kernel/homogeneous_vector.hpp new file mode 100644 index 000000000..001a57168 --- /dev/null +++ b/include/meevax/kernel/homogeneous_vector.hpp @@ -0,0 +1,135 @@ +/* + Copyright 2018-2023 Tatsuya Yamasaki. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*/ + +#ifndef INCLUDED_MEEVAX_KERNEL_HOMOGENEOUS_VECTOR_HPP +#define INCLUDED_MEEVAX_KERNEL_HOMOGENEOUS_VECTOR_HPP + +#include + +#include +#include + +namespace meevax +{ +inline namespace kernel +{ + template + struct homogeneous_vector + { + std::valarray values; + + explicit homogeneous_vector() = default; + + explicit homogeneous_vector(object const& xs) + : values(length(xs)) + { + std::generate(std::begin(values), std::end(values), [xs = xs]() mutable + { + let const x = car(xs); + xs = cdr(xs); + return input_cast(x); + }); + } + + explicit homogeneous_vector(std::size_t size, object const& x) + : values(input_cast(x), size) + {} + + explicit homogeneous_vector(homogeneous_vector const& v, std::size_t begin, std::size_t end) + : values(v.values[std::slice(begin, begin < end ? end - begin : 0, 1)]) + {} + + explicit homogeneous_vector(homogeneous_vector const& a, homogeneous_vector const& b) + : values(a.values.size() + b.values.size()) + { + values[std::slice(0, a.values.size(), 1)] = a.values; + values[std::slice(a.values.size(), b.values.size(), 1)] = b.values; + } + + explicit homogeneous_vector(T const* data, std::size_t size) + : values(data, size) + {} + + static auto tag() -> auto const& + { + auto static const tag = lexical_cast(std::is_integral_v ? std::is_signed_v ? 's' : 'u' : 'f', sizeof(T) * CHAR_BIT); + return tag; + } + + template + static auto input_cast(object const& x) -> T + { + using Us = std::tuple; + + if constexpr (I < std::tuple_size_v) + { + using U = std::tuple_element_t; + return x.is() ? static_cast(x.as()) : input_cast(x); + } + else + { + throw error(make(lexical_cast(tag(), "vector expects real numbers to store, but was given a value that is not")), x); + } + } + + static auto output_cast(T x) + { + return make, T, exact_integer>>(x); + } + }; + + template + auto operator <<(std::ostream & output, homogeneous_vector const& datum) -> std::ostream & + { + static_assert(std::is_arithmetic_v); + + output << magenta("#", std::is_integral_v ? std::is_signed_v ? 's' : 'u' : 'f', sizeof(T) * CHAR_BIT, "("); + + auto whitespace = ""; + + for (auto const& value : datum.values) + { + output << std::exchange(whitespace, " ") << cyan(homogeneous_vector::output_cast(value)); + } + + return output << magenta(")"); + } + + template + auto operator ==(homogeneous_vector const& a, homogeneous_vector const& b) -> bool + { + auto check = [](std::valarray const& xs) + { + return std::all_of(std::begin(xs), std::end(xs), [](auto x) { return x; }); + }; + + return check(a.values == b.values); + } + + using f32vector = homogeneous_vector; + using f64vector = homogeneous_vector; + using s8vector = homogeneous_vector; + using s16vector = homogeneous_vector; + using s32vector = homogeneous_vector; + using s64vector = homogeneous_vector; + using u8vector = homogeneous_vector; + using u16vector = homogeneous_vector; + using u32vector = homogeneous_vector; + using u64vector = homogeneous_vector; +} // namespace kernel +} // namespace meevax + +#endif // INCLUDED_MEEVAX_KERNEL_HOMOGENEOUS_VECTOR_HPP diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 96a5d54ce..ea58d1b5c 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -19,45 +19,45 @@ #include #include +#include namespace meevax { inline namespace kernel { - class library : public environment + struct library : public environment { template - struct is_library_declaration + struct is_declaration : public std::false_type {}; template - struct is_library_declaration().resolve(std::declval()))>> + struct is_declaration().resolve(std::declval()))>> : public std::true_type {}; template - static constexpr auto is_library_declaration_v = is_library_declaration::value; + static constexpr auto is_declaration_v = is_declaration::value; - public: let declarations = unit; let subset = unit; template )> - explicit library(F&& f) + explicit library(F f) { - std::invoke(std::forward(f), *this); + f(*this); } explicit library(object const&); - static auto boot() -> void; + friend auto boot() -> void; template auto declare(Ts&&... xs) -> decltype(auto) { - if constexpr (is_library_declaration_v) + if constexpr (is_declaration_v) { return std::decay_t(std::forward(xs)...).resolve(*this); } @@ -82,16 +82,25 @@ inline namespace kernel auto operator <<(std::ostream &, library const&) -> std::ostream &; /* - NOTE: In order to improve the usability of the help procedure, it is - desirable to sort by library name in lexicographical order. + In order to improve the usability of the help procedure, it is desirable + to sort by library name in lexicographical order. */ - extern std::map libraries; + auto libraries() -> std::map &; - template - auto define_library(std::string const& name, Ts&&... xs) + template + auto define(std::string const& name, Ts&&... xs) -> decltype(auto) { - return libraries.emplace(name, std::forward(xs)...); + if constexpr (std::is_same_v) + { + return libraries().emplace(name, std::forward(xs)...); + } + else + { + return interaction_environment().as().define(name, std::forward(xs)...); + } } + + auto boot() -> void; } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/number.hpp b/include/meevax/kernel/number.hpp index d29b99b90..22062e5e0 100644 --- a/include/meevax/kernel/number.hpp +++ b/include/meevax/kernel/number.hpp @@ -17,12 +17,9 @@ #ifndef INCLUDED_MEEVAX_KERNEL_NUMERICAL_HPP #define INCLUDED_MEEVAX_KERNEL_NUMERICAL_HPP -#include // std::unique_ptr - #include #include #include -#include namespace meevax { @@ -286,488 +283,126 @@ inline namespace kernel auto operator / (object const&, object const&) -> object; auto operator % (object const&, object const&) -> object; - using plus = std::plus; - - using minus = std::minus; - - using multiplies = std::multiplies; - - using divides = std::divides; - - struct modulus + template + auto inexact_cast(T&& x) -> decltype(auto) { - template - auto operator ()(T&& x, U&& y) const + if constexpr (std::is_same_v, complex>) { - if constexpr (std::is_floating_point_v> and - std::is_floating_point_v>) - { - return std::fmod(x, y); - } - else - { - return x % y; - } + return std::complex(std::forward(x)); } - }; + else if constexpr (std::is_floating_point_v>) + { + return std::forward(x); + } + else + { + return static_cast(std::forward(x)); + } + } - struct equal_to + template + auto inexact_equals(T const& x, U const& y) { - template - auto operator ()(T&& x, U&& y) const + if constexpr (std::is_floating_point_v and + std::is_floating_point_v) { - if constexpr (std::is_floating_point_v> and - std::is_floating_point_v>) + if (std::isnan(x) and std::isnan(y)) { - if (std::isnan(x) and std::isnan(y)) - { - return true; - } - else if (std::isinf(x) or std::isinf(y)) - { - return x == y; - } - else - { - return std::abs(x - y) <= std::numeric_limits() - std::declval())>::epsilon(); - } + return true; } - else + else if (std::isinf(x) or std::isinf(y)) { return x == y; } + else + { + using R = std::decay_t() - std::declval())>; + + return std::abs(x - y) <= std::numeric_limits::epsilon(); + } + } + else + { + return x == y; } - }; + } - using less = std::less; +inline namespace number +{ + auto equals(object const&, object const&) -> bool; - using less_equal = std::less_equal; + auto not_equals(object const&, object const&) -> bool; - using greater = std::greater; + auto less_than(object const&, object const&) -> bool; - using greater_equal = std::greater_equal; + auto less_than_or_equals(object const&, object const&) -> bool; - template - struct application - { - static inline constexpr F f {}; + auto greater_than(object const&, object const&) -> bool; - template - auto canonicalize(T&& x) -> decltype(auto) - { - if constexpr (std::is_same_v, object>) - { - return std::forward(x); - } - else if constexpr (std::is_same_v, complex>) - { - return x.canonicalize(); - } - else if constexpr (std::is_same_v, ratio>) - { - if (x.denominator() == 1) - { - return make(x.numerator()); - } - else - { - return make(std::forward(x)); - } - } - else - { - return make(std::forward(x)); - } - } + auto greater_than_or_equals(object const&, object const&) -> bool; - auto operator ()(object const& x) -> object - { - return canonicalize(f(x.as>>())); - } + auto exact(object const&) -> object; - auto operator ()(object const& x, - object const& y) -> object - { - return canonicalize(f(x.as>>(), - y.as>>())); - } - }; + auto inexact(object const&) -> object; - template - auto apply_arithmetic(object const& x) -> object - { - static const std::unordered_map< - std::type_index, - std::function - > apply - { - { typeid(exact_integer), application() }, - { typeid(ratio ), application() }, - { typeid(float ), application() }, - { typeid(double ), application() }, - { typeid(complex ), application() }, - }; - - return apply.at(x.type())(x); - } + auto is_complex(object const&) -> bool; - template - auto apply_arithmetic(object const& x, object const& y) -> object - { - #define APPLY(T, U) { type_index<2>(typeid(T), typeid(U)), application() } + auto is_real(object const&) -> bool; - static const std::unordered_map< - type_index<2>, - std::function - > apply - { - APPLY(exact_integer, exact_integer), APPLY(exact_integer, ratio), APPLY(exact_integer, float), APPLY(exact_integer, double), APPLY(exact_integer, complex), - APPLY(ratio, exact_integer), APPLY(ratio, ratio), APPLY(ratio, float), APPLY(ratio, double), APPLY(ratio, complex), - APPLY(float, exact_integer), APPLY(float, ratio), APPLY(float, float), APPLY(float, double), APPLY(float, complex), - APPLY(double, exact_integer), APPLY(double, ratio), APPLY(double, float), APPLY(double, double), APPLY(double, complex), - APPLY(complex, exact_integer), APPLY(complex, ratio), APPLY(complex, float), APPLY(complex, double), APPLY(complex, complex), - }; + auto is_rational(object const&) -> bool; - #undef APPLY + auto is_integer(object const&) -> bool; - return apply.at(type_index<2>(x.type(), y.type()))(x, y); - } + auto is_finite(object const&) -> bool; - template )> - auto inexact_cast(U&& x) -> decltype(auto) - { - if constexpr (std::is_same_v, complex>) - { - return std::complex(std::forward(x)); - } - else if constexpr (std::is_floating_point_v>) - { - return std::forward(x); - } - else - { - return static_cast(std::forward(x)); - } - } + auto is_infinite(object const&) -> bool; - struct exact - { - template - auto operator ()(T&& x) const -> decltype(auto) - { - if constexpr (std::is_same_v, complex>) - { - return complex(apply_arithmetic(x.real()), - apply_arithmetic(x.imag())); - } - else if constexpr (std::is_floating_point_v>) - { - return ratio(std::forward(x)); - } - else - { - return std::forward(x); - } - } - }; + auto is_nan(object const&) -> bool; - struct inexact - { - template - auto operator ()(T&& x) const -> decltype(auto) - { - if constexpr (std::is_same_v, complex>) - { - return complex(apply_arithmetic(x.real()), - apply_arithmetic(x.imag())); - } - else - { - return inexact_cast(std::forward(x)); - } - } - }; + auto sqrt(object const&) -> object; - struct is_complex - { - template - constexpr auto operator ()(T&&) const - { - return true; - } - }; + auto pow(object const&, object const&) -> object; - struct is_real - { - template - constexpr auto operator ()(T&& x) const - { - if constexpr (std::is_same_v, complex>) - { - return apply_arithmetic(x.imag(), e0).template as(); - } - else - { - return true; - } - } - }; + auto floor(object const&) -> object; - struct is_rational - { - template - constexpr auto operator ()(T&& x) const - { - if constexpr (std::is_floating_point_v>) - { - return not std::isnan(x) and not std::isinf(x); - } - else - { - return std::is_same_v, exact_integer> or - std::is_same_v, ratio>; - } - } - }; + auto ceil(object const&) -> object; - struct is_integer - { - template - constexpr auto operator ()(T&& x) const - { - if constexpr (std::is_same_v, complex>) - { - return apply_arithmetic(x.imag(), e0).template as() and apply_arithmetic(x.real()).template as(); - } - else if constexpr (std::is_floating_point_v>) - { - return x == std::trunc(x); - } - else if constexpr (std::is_same_v, ratio>) - { - return x.denominator() == 1; - } - else - { - return std::is_same_v, exact_integer>; - } - } - }; + auto trunc(object const&) -> object; - struct is_infinite - { - template - constexpr auto operator ()(T&& x) const - { - if constexpr (std::is_same_v, complex>) - { - return apply_arithmetic(x.real()).template as() or - apply_arithmetic(x.imag()).template as(); - } - else if constexpr (std::is_floating_point_v>) - { - return std::isinf(x); - } - else - { - return false; - } - } - }; + auto round(object const&) -> object; - struct is_finite - { - template - constexpr auto operator ()(T&& x) const - { - return not std::invoke(is_infinite(), std::forward(x)); - } - }; + auto sin(object const&) -> object; - struct is_nan - { - template - constexpr auto operator ()(T&& x) const - { - if constexpr (std::is_same_v, complex>) - { - return apply_arithmetic(x.real()).template as() or - apply_arithmetic(x.imag()).template as(); - } - else if constexpr (std::is_floating_point_v>) - { - return std::isnan(x); - } - else - { - return false; - } - } - }; + auto cos(object const&) -> object; - struct sqrt - { - template - constexpr auto operator ()(T&& x) const -> decltype(auto) - { - if constexpr (std::is_same_v, complex>) - { - auto const z = std::sqrt(inexact_cast(std::forward(x))); - return complex(make(z.real()), make(z.imag())); - } - else - { - auto sqrt = [](auto&& x) - { - if constexpr (std::is_same_v, exact_integer>) - { - auto const [s, r] = exact_integer_sqrt(x); - return r == 0 ? make(s) : make(std::sqrt(inexact_cast(x))); - } - else - { - return make(std::sqrt(inexact_cast(x))); - } - }; - - return x < exact_integer(0) ? make(e0, sqrt(exact_integer(0) - x)) : sqrt(x); - } - } - }; + auto tan(object const&) -> object; - struct expt - { - template - auto operator ()(T&& x, U&& y) const -> decltype(auto) - { - if constexpr (std::is_same_v, complex> or - std::is_same_v, complex>) - { - auto const z = std::pow(inexact_cast(std::forward(x)), - inexact_cast(std::forward(y))); - return complex(make(z.real()), make(z.imag())); - } - else if constexpr (std::is_same_v, exact_integer> and - std::is_same_v, exact_integer>) - { - exact_integer result {}; - mpz_pow_ui(result.value, x.value, static_cast(y)); - return result; - } - else - { - return std::pow(inexact_cast(std::forward(x)), - inexact_cast(std::forward(y))); - } - } - }; + auto asin(object const&) -> object; - struct atan2 - { - template - auto operator ()(T&& x, U&& y) const -> decltype(auto) - { - if constexpr (std::is_same_v, complex> or - std::is_same_v, complex>) - { - throw std::invalid_argument("unsupported operation"); - return e0; // dummy return value. - } - else - { - return std::atan2(inexact_cast(std::forward(x)), - inexact_cast(std::forward(y))); - } - } - }; - - #define DEFINE(ROUND) \ - struct ROUND \ - { \ - template \ - constexpr auto operator ()(T&& x) const \ - { \ - if constexpr (std::is_floating_point_v>) \ - { \ - return std::ROUND(inexact_cast(x)); \ - } \ - else if constexpr (std::is_same_v, ratio>) \ - { \ - return exact_integer(std::ROUND(inexact_cast(x))); \ - } \ - else if constexpr (std::is_same_v, exact_integer>) \ - { \ - return std::forward(x); \ - } \ - else \ - { \ - return complex(apply_arithmetic(x.real()), \ - apply_arithmetic(x.imag())); \ - } \ - } \ - } + auto acos(object const&) -> object; - DEFINE(floor); - DEFINE(ceil); - DEFINE(trunc); - DEFINE(round); - - #undef DEFINE - - #define DEFINE(CMATH) \ - struct CMATH \ - { \ - template \ - auto operator ()(T&& x) const \ - { \ - if constexpr (std::is_same_v, complex>) \ - { \ - auto const z = std::CMATH(inexact_cast(std::forward(x))); \ - return complex(make(z.real()), make(z.imag())); \ - } \ - else \ - { \ - return std::CMATH(inexact_cast(std::forward(x))); \ - } \ - } \ - } + auto atan(object const&) -> object; - DEFINE(sin); DEFINE(asin); DEFINE(sinh); DEFINE(asinh); - DEFINE(cos); DEFINE(acos); DEFINE(cosh); DEFINE(acosh); - DEFINE(tan); DEFINE(atan); DEFINE(tanh); DEFINE(atanh); + auto atan(object const&, object const&) -> object; - DEFINE(exp); - DEFINE(log); + auto sinh(object const&) -> object; - #undef DEFINE + auto cosh(object const&) -> object; - template - struct number_to_string - { - template - auto operator ()(T&& z) const - { - if constexpr (std::is_floating_point_v>) - { - return string("TODO"); - } - else if constexpr (std::is_same_v, exact_integer>) - { - auto free = [](char * data) - { - void (*free)(void *, std::size_t); - mp_get_memory_functions(nullptr, nullptr, &free); - std::invoke(free, static_cast(data), std::strlen(data) + 1); - }; - - return string(std::unique_ptr(mpz_get_str(nullptr, Radix, z.value), free).get()); - } - else - { - return string("TODO"); - } - } - }; + auto tanh(object const&) -> object; + + auto asinh(object const&) -> object; + + auto acosh(object const&) -> object; + + auto atanh(object const&) -> object; + + auto exp(object const&) -> object; + + auto log(object const&) -> object; + + auto number_to_string(object const&, int) -> object; +} // namespace number } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/reader.hpp b/include/meevax/kernel/reader.hpp index 96f7ded92..8ecc113a9 100644 --- a/include/meevax/kernel/reader.hpp +++ b/include/meevax/kernel/reader.hpp @@ -20,6 +20,7 @@ #include #include #include +#include #include #include #include @@ -31,6 +32,8 @@ inline namespace kernel { auto get_codepoint(std::istream &) -> character::int_type; + auto get_digits(std::istream &) -> std::string; + auto get_token(std::istream &) -> std::string; auto ignore_nested_block_comment(std::istream &) -> std::istream &; @@ -41,53 +44,37 @@ inline namespace kernel template <> auto read(std::istream &) -> object; template <> auto read(std::istream &) -> object; - auto string_to_integer (std::string const&, int = 10) -> object; - auto string_to_rational(std::string const&, int = 10) -> object; - auto string_to_real (std::string const&, int = 10) -> object; - auto string_to_complex (std::string const&, int = 10) -> object; - auto string_to_number (std::string const&, int = 10) -> object; - - template - class reader + struct datum_label { - friend Environment; + std::string const n; - explicit constexpr reader() + template + explicit datum_label(Ts&&... xs) + : n { std::forward(xs)... } {} + }; - struct datum_label - { - std::uintptr_t value; - }; - - std::unordered_map datum_labels; + auto circulate(object const&, std::string const&) -> void; - auto finish(object const& xs, object const& datum) -> void - { - if (xs.is()) - { - finish(car(xs), datum); - - if (cdr(xs).is()) - { - cdr(xs) = datum; - } - else - { - finish(cdr(xs), datum); - } - } - } + auto make_integer (std::string const&, int = 10) -> object; + auto make_rational(std::string const&, int = 10) -> object; + auto make_real (std::string const&, int = 10) -> object; + auto make_complex (std::string const&, int = 10) -> object; + auto make_number (std::string const&, int = 10) -> object; - public: + template + struct reader + { using char_type = typename std::istream::char_type; - inline auto get_ready() const + std::unordered_map datum_labels; + + auto get_ready() const { return static_cast(std::cin); } - inline auto read(std::istream & is = std::cin) -> object + auto read(std::istream & is = std::cin) -> object { for (auto head = std::istream_iterator(is); head != std::istream_iterator(); ++head) { @@ -115,10 +102,11 @@ inline namespace kernel return static_cast(*this).evaluate(read(is)); case ';': // SRFI 62 - return read(is), read(is); + read(is); + return read(is); case '"': - return string_to_symbol(meevax::read(is.putback(c)).as()); + return make_symbol(meevax::read(is.putback(c)).as()); case '0': case '1': @@ -130,42 +118,50 @@ inline namespace kernel case '7': case '8': case '9': - if (std::uintptr_t n = 0; is.putback(c) >> n) + switch (auto n = get_digits(is.putback(c)); is.peek()) { - switch (auto c = is.get()) - { - case '#': - return datum_labels.at(n); + case '#': + is.ignore(1); - case '=': - if (auto && [iter, success] = datum_labels.emplace(n, make(n)); success) - { - let result = read(is); + if (auto iter = datum_labels.find(n); iter != std::end(datum_labels)) + { + return iter->second; + } + else + { + throw read_error(make("it is an error to attempt a forward reference"), + make(lexical_cast('#', n, '#'))); + } - finish(result, result); + case '=': + is.ignore(1); + if (auto [iter, success] = datum_labels.emplace(n, make(n)); success) + { + if (let const& xs = read(is); xs != iter->second) + { + circulate(xs, n); datum_labels.erase(n); - - return result; + return xs; } else { - throw read_error(make("duplicated datum-label declaration"), - make(n)); + return unit; } - - default: - throw read_error(make("unknown discriminator"), - make(lexical_cast("#", n, std::char_traits::to_char_type(c)))); } - } - else - { - return eof_object; + else + { + throw read_error(make("duplicated datum-label declaration"), + make(n)); + } + + default: + throw read_error(make("unknown discriminator"), + make(lexical_cast('#', n, is.get()))); } case 'b': - return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 2); + return make_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 2); case 'c': // Common Lisp return [](let const& xs) @@ -175,27 +171,77 @@ inline namespace kernel }(read(is)); case 'd': - return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 10); + return make_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 10); case 'e': - return apply_arithmetic(read(is)); // NOTE: Same as #,(exact (read)) + return exact(read(is)); // NOTE: Same as #,(exact (read)) case 'f': - get_token(is); - return f; + switch (auto const digits = get_digits(is); std::stoi(digits)) + { + case 32: + return make(read(is)); + + case 64: + return make(read(is)); + + default: + get_token(is); + return f; + } case 'i': - return apply_arithmetic(read(is)); // NOTE: Same as #,(inexact (read)) + return inexact(read(is)); // NOTE: Same as #,(inexact (read)) case 'o': - return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 8); + return make_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 8); + + case 's': + switch (auto const digits = get_digits(is); std::stoi(digits)) + { + case 8: + return make(read(is)); + + case 16: + return make(read(is)); + + case 32: + return make(read(is)); + + case 64: + return make(read(is)); + + default: + throw read_error(make("An unknown literal expression was encountered"), + make(lexical_cast("#s", digits))); + } case 't': get_token(is); return t; + case 'u': + switch (auto const digits = get_digits(is); std::stoi(digits)) + { + case 8: + return make(read(is)); + + case 16: + return make(read(is)); + + case 32: + return make(read(is)); + + case 64: + return make(read(is)); + + default: + throw read_error(make("An unknown literal expression was encountered"), + make(lexical_cast("#u", digits))); + } + case 'x': - return string_to_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 16); + return make_number(is.peek() == '#' ? lexical_cast(read(is)) : get_token(is), 16); case '(': is.putback(c); @@ -213,17 +259,43 @@ inline namespace kernel } case '\'': // 0x27 - return list(string_to_symbol("quote"), read(is)); + return list(make_symbol("quote"), read(is)); + + case '(': // 0x28 + try + { + if (let const& x = read(is); x == eof_object) + { + return x; + } + else + { + return cons(x, read(is.putback(c))); + } + } + catch (std::integral_constant const&) + { + return unit; + } + catch (std::integral_constant const&) + { + let const x = read(is); + is.ignore(std::numeric_limits::max(), ')'); + return x; + } + + case ')': // 0x29 + throw std::integral_constant(); case ',': // 0x2C switch (is.peek()) { case '@': is.ignore(1); - return list(string_to_symbol("unquote-splicing"), read(is)); + return list(make_symbol("unquote-splicing"), read(is)); default: - return list(string_to_symbol("unquote"), read(is)); + return list(make_symbol("unquote"), read(is)); } case ';': // 0x3B @@ -231,39 +303,17 @@ inline namespace kernel break; case '`': // 0x60 - return list(string_to_symbol("quasiquote"), read(is)); + return list(make_symbol("quasiquote"), read(is)); case '|': // 0x7C - return string_to_symbol(meevax::read(is.putback(c)).as()); - - case '(': - case '[': - case '{': - try - { - let const kar = read(is); - return cons(kar, read(is.putback(c))); - } - catch (std::integral_constant const&) { return character::eq(c, '(') ? unit : throw; } - catch (std::integral_constant const&) { return character::eq(c, '[') ? unit : throw; } - catch (std::integral_constant const&) { return character::eq(c, '{') ? unit : throw; } - catch (std::integral_constant const&) - { - let const kdr = read(is); - - switch (c) - { - case '(': is.ignore(std::numeric_limits::max(), ')'); break; - case '[': is.ignore(std::numeric_limits::max(), ']'); break; - case '{': is.ignore(std::numeric_limits::max(), '}'); break; - } - - return kdr; - } + return make_symbol(meevax::read(is.putback(c)).as()); - case ')': throw std::integral_constant(); - case ']': throw std::integral_constant(); - case '}': throw std::integral_constant(); + case '[': // 0x5B + case ']': // 0x5D + case '{': // 0x7B + case '}': // 0x7D + throw read_error(make("left and right square and curly brackets (braces) are reserved for possible future extensions to the language"), + make(c)); default: if (auto const& token = get_token(is.putback(c)); token == ".") @@ -272,11 +322,11 @@ inline namespace kernel } else try { - return string_to_number(token, 10); + return make_number(token, 10); } - catch (...) + catch (std::invalid_argument const&) { - return string_to_symbol(token); + return make_symbol(token); } } } @@ -284,7 +334,7 @@ inline namespace kernel return eof_object; } - inline auto read(std::string const& s) -> decltype(auto) + auto read(std::string const& s) -> decltype(auto) { auto port = std::stringstream(s); return read(port); diff --git a/include/meevax/kernel/symbol.hpp b/include/meevax/kernel/symbol.hpp index e5275ff42..41f94626c 100644 --- a/include/meevax/kernel/symbol.hpp +++ b/include/meevax/kernel/symbol.hpp @@ -26,16 +26,16 @@ inline namespace kernel { struct symbol : public identifier { - std::string const std_string; + std::string const name; template explicit symbol(Ts&&... xs) - : std_string { std::forward(xs)... } + : name { std::forward(xs)... } {} operator std::string() const noexcept { - return std_string; + return name; } }; @@ -52,12 +52,12 @@ inline namespace kernel template )> auto operator ==(symbol const& a, T const& b) -> bool { - return a.std_string == b; + return a.name == b; } - extern std::unordered_map symbols; + auto symbols() -> std::unordered_map &; - auto string_to_symbol(std::string const&) -> object const&; + auto make_symbol(std::string const&) -> object const&; } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/syntactic_environment.hpp b/include/meevax/kernel/syntactic_environment.hpp index 1dde08ae8..a8366c385 100644 --- a/include/meevax/kernel/syntactic_environment.hpp +++ b/include/meevax/kernel/syntactic_environment.hpp @@ -28,7 +28,6 @@ inline namespace kernel template struct syntactic_environment : public virtual pair // ( . ) { - protected: struct syntactic_closure : public identifier { let const environment; @@ -98,14 +97,14 @@ inline namespace kernel } }; - static auto core_syntactic_environment() + static auto rename(std::string const& variable) { auto bind = [](auto&& name, auto&& compiler) { - return make(string_to_symbol(name), make(name, compiler)); + return make(make_symbol(name), make(name, compiler)); }; - let static const core = make( + let static const core_syntactic_environment = make( list(), list(bind("begin" , syntax::sequence ), bind("call-with-current-continuation!", syntax::call_with_current_continuation), @@ -122,18 +121,7 @@ inline namespace kernel bind("quote-syntax" , syntax::quote_syntax ), bind("set!" , syntax::set ))); - return core; - } - - static auto rename(object const& variable) - { - assert(variable.is()); - return make(core_syntactic_environment(), unit, variable); - } - - static auto rename(std::string const& variable) - { - return rename(string_to_symbol(variable)); + return make(core_syntactic_environment, unit, make_symbol(variable)); } struct syntax @@ -230,7 +218,7 @@ inline namespace kernel continuation); } - static COMPILER(procedure_call) /* --------------------------------------- + static COMPILER(call) /* ------------------------------------------------- * * R7RS 4.1.3. Procedure calls * @@ -932,7 +920,6 @@ inline namespace kernel #undef COMPILER }; - public: auto operator ()(object const& expression, object const& local, object const& continuation = list(make(instruction::stop)), @@ -1019,7 +1006,7 @@ inline namespace kernel } else { - return syntax::procedure_call(*this, expression, local, continuation, ellipsis); + return syntax::call(*this, expression, local, continuation, ellipsis); } } @@ -1043,11 +1030,11 @@ inline namespace kernel { if constexpr (std::is_constructible_v) { - return define(string_to_symbol(name), make(name, std::forward(xs)...)); + return define(make_symbol(name), make(name, std::forward(xs)...)); } else { - return define(string_to_symbol(name), make(std::forward(xs)...)); + return define(make_symbol(name), make(std::forward(xs)...)); } } diff --git a/include/meevax/kernel/type_index.hpp b/include/meevax/kernel/type_index.hpp deleted file mode 100644 index a66b750c9..000000000 --- a/include/meevax/kernel/type_index.hpp +++ /dev/null @@ -1,76 +0,0 @@ -/* - Copyright 2018-2023 Tatsuya Yamasaki. - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*/ - -#ifndef INCLUDED_MEEVAX_KERNEL_TYPE_INDEX_HPP -#define INCLUDED_MEEVAX_KERNEL_TYPE_INDEX_HPP - -#include -#include -#include -#include - -namespace meevax -{ -inline namespace kernel -{ - template - struct type_index - { - std::array type_infos; - - template - explicit type_index(Ts&&... xs) - : type_infos { std::addressof(xs)... } - {} - - auto hash_code() const - { - return std::accumulate(std::begin(type_infos), std::end(type_infos), 0, [](auto&& lhs, auto&& rhs) - { - return lhs xor rhs->hash_code(); // BAD HASHING - }); - } - }; - - template - auto operator ==(type_index const& lhs, type_index const& rhs) - { - for (auto i = 0; i < N; ++i) - { - if (lhs.type_infos[i] != rhs.type_infos[i]) - { - return false; - } - } - - return true; - } -} // namespace kernel -} // namespace meevax - -namespace std -{ - template - struct hash> - { - auto operator()(meevax::type_index const& index) const - { - return index.hash_code(); - } - }; -} - -#endif // INCLUDED_MEEVAX_KERNEL_TYPE_INDEX_HPP diff --git a/include/meevax/kernel/version.hpp b/include/meevax/kernel/version.hpp index 75678534a..eeb7adf1f 100644 --- a/include/meevax/kernel/version.hpp +++ b/include/meevax/kernel/version.hpp @@ -17,27 +17,20 @@ #ifndef INCLUDED_MEEVAX_KERNEL_VERSION_HPP #define INCLUDED_MEEVAX_KERNEL_VERSION_HPP +#include + #include -#include #include namespace meevax { inline namespace kernel { - auto version() -> object const&; - - auto major_version() -> object const&; - - auto minor_version() -> object const&; - - auto patch_version() -> object const&; - - auto exact_version() -> object const&; + auto help() noexcept -> std::string_view; auto features() -> object const&; - auto help() -> std::string const&; + auto version() -> object const&; } // namespace kernel } // namespace meevax diff --git a/include/meevax/memory/pointer_set.hpp b/include/meevax/memory/pointer_set.hpp index 9bc389e58..56c05e71c 100644 --- a/include/meevax/memory/pointer_set.hpp +++ b/include/meevax/memory/pointer_set.hpp @@ -234,8 +234,6 @@ inline namespace memory explicit pointer_set() : pages {} { - pages.reserve(64); - assert(pages.size() == 0); assert(begin() == end()); } @@ -245,12 +243,6 @@ inline namespace memory return std::lower_bound(std::begin(pages), std::end(pages), page_number_of(p)); } - [[deprecated]] - auto page_count() const noexcept - { - return pages.size(); - } - auto size() const noexcept { return std::distance(begin(), end()); diff --git a/include/meevax/type_traits/integer.hpp b/include/meevax/type_traits/integer.hpp index e2a58ba6c..ec10c51f9 100644 --- a/include/meevax/type_traits/integer.hpp +++ b/include/meevax/type_traits/integer.hpp @@ -22,7 +22,7 @@ namespace meevax { -inline namespace memory +inline namespace type_traits { template using intN_t = std::conditional_t>>>; -} // namespace memory +} // namespace type_traits } // namespace meevax #endif // INCLUDED_MEEVAX_TYPE_TRAITS_INTEGER_HPP diff --git a/include/meevax/utility/combination.hpp b/include/meevax/utility/combination.hpp new file mode 100644 index 000000000..6842933b3 --- /dev/null +++ b/include/meevax/utility/combination.hpp @@ -0,0 +1,42 @@ +/* + Copyright 2018-2023 Tatsuya Yamasaki. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*/ + +#ifndef INCLUDED_MEEVAX_UTILITY_COMBINATION_HPP +#define INCLUDED_MEEVAX_UTILITY_COMBINATION_HPP + +#include +#include + +namespace meevax +{ +inline namespace kernel +{ + template + struct make_combination; + + template + struct make_combination> + { + using type = std::tuple, T>, + typename std::tuple_element_t, T>> ...>; + }; + + template + using combination = typename make_combination, std::make_index_sequence>::type; +} // namespace kernel +} // namespace meevax + +#endif // INCLUDED_MEEVAX_UTILITY_COMBINATION_HPP diff --git a/script/callgrind.sh b/script/callgrind.sh index 9ffc188d6..2c244caf4 100755 --- a/script/callgrind.sh +++ b/script/callgrind.sh @@ -4,6 +4,7 @@ stem="/tmp/callgrind" valgrind --tool=callgrind \ --callgrind-out-file=$stem.out \ + --dump-instr=yes \ --quiet \ meevax "$@" diff --git a/script/install.sh b/script/install.sh deleted file mode 100755 index a0c600565..000000000 --- a/script/install.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh -e - -root="$(git rev-parse --show-toplevel)" - -make() -{ - rm -rf "$2" - cmake -B "$2" -S "$(dirname "$2")" -DCMAKE_BUILD_TYPE=Debug -DCMAKE_CXX_COMPILER=g++ - cmake --build "$2" --target "$1" -} - -if dpkg -s meevax -then - sudo apt remove --yes meevax -fi - -make safe-install.deb "$root/build" - -make demo "$root/example/build" diff --git a/script/update.sh b/script/update.sh new file mode 100755 index 000000000..a5ccf1eb5 --- /dev/null +++ b/script/update.sh @@ -0,0 +1,23 @@ +#!/bin/sh -eu + +# ./script/update.sh -DCMAKE_BUILD_TYPE=Release -DCMAKE_CXX_COMPILER=g++ + +root="$(git rev-parse --show-toplevel)" + +build() +{ + rm -rf "$1/build" + cmake -B "$1/build" -S "$@" + cmake --build "$1/build" --target develop +} + +echo "0.4.$(($(git rev-list --no-merges --count HEAD) - 2854))" > "$root/VERSION" + +if dpkg -s meevax +then + sudo apt remove --yes meevax +fi + +build "$root" "$@" + +build "$root/example" "$@" diff --git a/script/version.sh b/script/version.sh deleted file mode 100755 index 34ad59c74..000000000 --- a/script/version.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/sh - -root="$(git rev-parse --show-toplevel)" - -current_version() -{ - # count="$(git rev-list --count HEAD)" - # echo "0.3.$((count - 2135))" - - count="$(git rev-list --no-merges --count HEAD)" - echo "0.4.$((count - 2854))" -} - -update_version() -{ - current_version > "$root/VERSION" -} - -list_version() -{ - git fetch origin --tags - git tag --list --sort=version:refname | sed -e 's/^/ /' - echo "\e[32m* v$(current_version)\e[0m" -} - -update_version diff --git a/src/kernel/complex.cpp b/src/kernel/complex.cpp index 2ee37638b..30f9da8e2 100644 --- a/src/kernel/complex.cpp +++ b/src/kernel/complex.cpp @@ -31,16 +31,16 @@ inline namespace kernel if (std::smatch result; std::regex_match(token, result, rectangular)) { - std::get<0>(*this) = string_to_real(result[1].length() == 0 ? "0" : result.str(1), radix); - std::get<1>(*this) = string_to_real(result[2].length() == 1 ? result.str(2) + "1" : result.str(2), radix); + std::get<0>(*this) = make_real(result[1].length() == 0 ? "0" : result.str(1), radix); + std::get<1>(*this) = make_real(result[2].length() == 1 ? result.str(2) + "1" : result.str(2), radix); } else if (std::regex_match(token, result, polar)) { - auto const magnitude = string_to_real(result.str(1), radix); - auto const angle = string_to_real(result.str(2), radix); + auto const magnitude = make_real(result.str(1), radix); + auto const angle = make_real(result.str(2), radix); - std::get<0>(*this) = magnitude * apply_arithmetic(angle); - std::get<1>(*this) = magnitude * apply_arithmetic(angle); + std::get<0>(*this) = magnitude * cos(angle); + std::get<1>(*this) = magnitude * sin(angle); } else { @@ -50,7 +50,7 @@ inline namespace kernel auto complex::canonicalize() const -> object { - if (apply_arithmetic(imag(), e0).as()) + if (equals(imag(), e0)) { return real(); } @@ -72,16 +72,16 @@ inline namespace kernel complex::operator std::complex() { - assert(apply_arithmetic(real())); - assert(apply_arithmetic(imag())); + assert(is_real(real())); + assert(is_real(imag())); - return std::complex(apply_arithmetic(real()).as(), - apply_arithmetic(imag()).as()); + return std::complex(inexact(real()).as(), + inexact(imag()).as()); } auto operator <<(std::ostream & os, complex const& z) -> std::ostream & { - if (apply_arithmetic(z.imag(), e0).as()) + if (equals(z.imag(), e0)) { return os << z.real(); } diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index cc1594722..12b3ecdbc 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -25,7 +25,7 @@ inline namespace kernel { if (car(expression).is() and car(expression).as() == "define-library") { - define_library(lexical_cast(cadr(expression)), cddr(expression)); + meevax::define(lexical_cast(cadr(expression)), cddr(expression)); return cadr(expression); } else if (car(expression).is() and car(expression).as() == "import") @@ -107,7 +107,7 @@ inline namespace kernel auto environment::operator [](std::string const& variable) -> object const& { - return (*this)[string_to_symbol(variable)]; + return (*this)[make_symbol(variable)]; } auto operator <<(std::ostream & os, environment const& datum) -> std::ostream & @@ -115,11 +115,11 @@ inline namespace kernel return os << magenta("#,(") << green("environment ") << faint("#;", &datum) << magenta(")"); } - template class configurator; + template struct configurator; - template class dynamic_environment; + template struct dynamic_environment; - template class reader; + template struct reader; template struct syntactic_environment; } // namespace kernel diff --git a/src/kernel/exact_integer.cpp b/src/kernel/exact_integer.cpp index cd8cba26f..a62f97aab 100644 --- a/src/kernel/exact_integer.cpp +++ b/src/kernel/exact_integer.cpp @@ -53,23 +53,49 @@ inline namespace kernel mpz_init_set(value, z); } - exact_integer::exact_integer(int rhs) - : exact_integer(static_cast(rhs)) - {} + exact_integer::exact_integer(std::int8_t si) + { + mpz_init_set_si(value, si); + } + + exact_integer::exact_integer(std::int16_t si) + { + mpz_init_set_si(value, si); + } + + exact_integer::exact_integer(std::int32_t si) + { + mpz_init_set_si(value, si); + } + + exact_integer::exact_integer(std::int64_t si) + { + mpz_init_set_si(value, si); + } - exact_integer::exact_integer(signed long rhs) + exact_integer::exact_integer(std::uint8_t ui) { - mpz_init_set_si(value, rhs); + mpz_init_set_ui(value, ui); } - exact_integer::exact_integer(unsigned long rhs) + exact_integer::exact_integer(std::uint16_t ui) { - mpz_init_set_ui(value, rhs); + mpz_init_set_ui(value, ui); } - exact_integer::exact_integer(double rhs) + exact_integer::exact_integer(std::uint32_t ui) { - mpz_init_set_d(value, rhs); + mpz_init_set_ui(value, ui); + } + + exact_integer::exact_integer(std::uint64_t ui) + { + mpz_init_set_ui(value, ui); + } + + exact_integer::exact_integer(double d) + { + mpz_init_set_d(value, d); } exact_integer::exact_integer(std::string const& s, int radix) @@ -110,24 +136,49 @@ inline namespace kernel return (*value)._mp_size; } - exact_integer::operator int() const + exact_integer::operator std::int8_t() const { - return static_cast(*this); + return mpz_get_si(value); } - exact_integer::operator signed long() const + exact_integer::operator std::int16_t() const { return mpz_get_si(value); } - exact_integer::operator unsigned long() const + exact_integer::operator std::int32_t() const + { + return mpz_get_si(value); + } + + exact_integer::operator std::int64_t() const + { + return mpz_get_si(value); + } + + exact_integer::operator std::uint8_t() const + { + return mpz_get_ui(value); + } + + exact_integer::operator std::uint16_t() const + { + return mpz_get_ui(value); + } + + exact_integer::operator std::uint32_t() const + { + return mpz_get_ui(value); + } + + exact_integer::operator std::uint64_t() const { return mpz_get_ui(value); } exact_integer::operator float() const { - return static_cast(*this); + return mpz_get_d(value); } exact_integer::operator double() const @@ -158,14 +209,7 @@ inline namespace kernel auto operator <<(std::ostream & os, exact_integer const& datum) -> std::ostream & { - auto free = [](char * data) - { - void (*free)(void *, std::size_t); - mp_get_memory_functions(nullptr, nullptr, &free); - std::invoke(free, static_cast(data), std::strlen(data) + 1); - }; - - return os << cyan(std::unique_ptr(mpz_get_str(nullptr, 10, datum.value), free).get()); + return os << cyan(std::unique_ptr(mpz_get_str(nullptr, 10, datum.value)).get()); } auto exact_integer_sqrt(exact_integer const& x) -> std::tuple diff --git a/src/kernel/import_set.cpp b/src/kernel/import_set.cpp index e497edefd..12fe8702c 100644 --- a/src/kernel/import_set.cpp +++ b/src/kernel/import_set.cpp @@ -78,7 +78,7 @@ inline namespace kernel { return map1([&](let const& identity) { - return make(string_to_symbol(car(prefixes).as() + identity.as().symbol().as()), + return make(make_symbol(car(prefixes).as() + identity.as().symbol().as()), identity.as().load()); }, resolve_library(import_set)); @@ -118,7 +118,7 @@ inline namespace kernel return rename(cadr(form)) (cddr(form)); } - else if (auto iter = libraries.find(lexical_cast(form)); iter != std::end(libraries)) + else if (auto iter = libraries().find(lexical_cast(form)); iter != std::end(libraries())) { return std::get<1>(*iter).resolve(); } diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 3742bddb1..84534f4f4 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -14,9 +14,11 @@ limitations under the License. */ +#include +#include + #include #include -#include #include namespace meevax @@ -27,9 +29,57 @@ inline namespace kernel : declarations { declarations } {} - auto library::boot() -> void + auto library::evaluate(object const& declaration) -> void { - define_library("(meevax character)", [](library & library) + if (declaration[0].is() and declaration[0].as() == "export") + { + for (let const& form : cdr(declaration)) + { + declare(form); + } + } + else if (declaration[0].is() and declaration[0].as() == "begin") + { + for (let const& command_or_definition : cdr(declaration)) + { + evaluate(command_or_definition); + } + } + else + { + environment::evaluate(declaration); // Non-standard extension. + } + } + + auto library::resolve() -> object const& + { + if (not declarations.is()) + { + for (let const& declaration : declarations) + { + evaluate(declaration); + } + + declarations = unit; + } + + return subset; + } + + auto operator <<(std::ostream & os, library const& library) -> std::ostream & + { + return os << library.global(); + } + + auto libraries() -> std::map & + { + static auto libraries = std::map(); + return libraries; + } + + auto boot() -> void + { + define("(meevax character)", [](library & library) { library.define("char?", [](let const& xs) { @@ -54,12 +104,12 @@ inline namespace kernel }); }); - define_library("(meevax complex)", [](library & library) + define("(meevax complex)", [](library & library) { library.define("make-rectangular", [](let const& xs) { - assert(apply_arithmetic(xs[0])); - assert(apply_arithmetic(xs[1])); + assert(is_real(xs[0])); + assert(is_real(xs[1])); return make(xs[0], xs[1]); }); @@ -75,9 +125,9 @@ inline namespace kernel }); }); - define_library("(meevax context)", [](library & library) + define("(meevax context)", [](library & library) { - library.define("emergency-exit", [](let const& xs) -> object + library.define("emergency-exit", [](let const& xs) { if (let const& status = car(xs); status.is()) { @@ -92,9 +142,21 @@ inline namespace kernel throw static_cast(status.as()); } }); + + library.define("command-line", [](let const&) + { + let xs = unit; + + for (auto&& each : interaction_environment().as().command_line) + { + xs = cons(make(each), xs); + } + + return reverse(xs); + }); }); - define_library("(meevax comparator)", [](library & library) + define("(meevax comparator)", [](library & library) { library.define("eq?", [](let const& xs) { @@ -107,8 +169,10 @@ inline namespace kernel }); }); - define_library("(meevax core)", [](library & library) + define("(meevax core)", [](library & library) { + using syntax = environment::syntax; + library.define("begin", syntax::sequence); library.define("call-with-current-continuation!", syntax::call_with_current_continuation); library.define("current", syntax::current); @@ -125,7 +189,7 @@ inline namespace kernel library.define("set!", syntax::set); }); - define_library("(meevax environment)", [](library & library) + define("(meevax environment)", [](library & library) { library.define("environment", [](let const& xs) { @@ -155,7 +219,7 @@ inline namespace kernel }); }); - define_library("(meevax error)", [](library & library) + define("(meevax error)", [](library & library) { library.define("throw", [](let const& xs) -> object { @@ -184,11 +248,11 @@ inline namespace kernel library.define("kernel-exception-handler-set!", [](let const& xs) { - return raise = car(xs); + return environment::raise = car(xs); }); }); - define_library("(meevax experimental)", [](library & library) + define("(meevax experimental)", [](library & library) { library.define("type-of", [](let const& xs) { @@ -215,7 +279,7 @@ inline namespace kernel }); }); - define_library("(meevax function)", [](library & library) + define("(meevax function)", [](library & library) { library.define("closure?", [](let const& xs) { @@ -238,7 +302,7 @@ inline namespace kernel }); }); - define_library("(meevax garbage-collector)", [](library & library) + define("(meevax garbage-collector)", [](library & library) { library.define("gc-collect", []() { @@ -251,123 +315,102 @@ inline namespace kernel }); }); - define_library("(meevax inexact)", [](library & library) + define("(meevax inexact)", [](library & library) { library.define("finite?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_finite(xs[0]); }); library.define("infinite?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_infinite(xs[0]); }); library.define("nan?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_nan(xs[0]); }); library.define("exp", [](let const& xs) { - return apply_arithmetic(car(xs)); + return exp(xs[0]); }); library.define("sqrt", [](let const& xs) { - return apply_arithmetic(car(xs)); + return sqrt(xs[0]); }); library.define("log", [](let const& xs) { - return cdr(xs).is() ? apply_arithmetic(car(xs)) / apply_arithmetic(cadr(xs)) - : apply_arithmetic(car(xs)); + return cdr(xs).is() ? log(xs[0]) / log(xs[1]) + : log(xs[0]); }); library.define("sin", [](let const& xs) { - return apply_arithmetic(car(xs)); + return sin(xs[0]); }); library.define("cos", [](let const& xs) { - return apply_arithmetic(car(xs)); + return cos(xs[0]); }); library.define("tan", [](let const& xs) { - return apply_arithmetic(car(xs)); + return tan(xs[0]); }); library.define("asin", [](let const& xs) { - return apply_arithmetic(car(xs)); + return asin(xs[0]); }); library.define("acos", [](let const& xs) { - return apply_arithmetic(car(xs)); + return acos(xs[0]); }); library.define("atan", [](let const& xs) { - return cdr(xs).is() ? apply_arithmetic(car(xs), cadr(xs)) - : apply_arithmetic(car(xs)); + return cdr(xs).is() ? atan(xs[0], xs[1]) + : atan(xs[0]); }); library.define("sinh", [](let const& xs) { - return apply_arithmetic(car(xs)); + return sinh(xs[0]); }); library.define("cosh", [](let const& xs) { - return apply_arithmetic(car(xs)); + return cosh(xs[0]); }); library.define("tanh", [](let const& xs) { - return apply_arithmetic(car(xs)); + return tanh(xs[0]); }); library.define("asinh", [](let const& xs) { - return apply_arithmetic(car(xs)); + return asinh(xs[0]); }); library.define("acosh", [](let const& xs) { - return apply_arithmetic(car(xs)); + return acosh(xs[0]); }); library.define("atanh", [](let const& xs) { - return apply_arithmetic(car(xs)); + return atanh(xs[0]); }); }); - define_library("(meevax list)", [](library & library) + define("(meevax list)", [](library & library) { library.define("null?", [](let const& xs) { @@ -429,8 +472,10 @@ inline namespace kernel }); }); - define_library("(meevax macro)", [](library & library) + define("(meevax macro)", [](library & library) { + using syntactic_closure = environment::syntactic_closure; + library.define("identifier?", [](let const& xs) { return car(xs).is_also(); @@ -452,136 +497,121 @@ inline namespace kernel }); }); - define_library("(meevax number)", [](library & library) + define("(meevax number)", [](library & library) { library.define("number?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_complex(xs[0]); }); library.define("complex?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_complex(xs[0]); }); library.define("real?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_real(xs[0]); }); library.define("rational?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_rational(xs[0]); }); library.define("integer?", [](let const& xs) { - try - { - return apply_arithmetic(car(xs)); - } - catch (std::out_of_range const&) - { - return f; - } + return is_integer(xs[0]); }); library.define("exact-integer?", [](let const& xs) { - return car(xs).is(); + return xs[0].is(); }); - library.define("%complex?", [](let const& xs) + library.define("imaginary?", [](let const& xs) { - return car(xs).is(); + return xs[0].is(); }); library.define("ratio?", [](let const& xs) { - return car(xs).is(); + return xs[0].is(); }); library.define("single-float?", [](let const& xs) { - return car(xs).is(); + return xs[0].is(); }); library.define("double-float?", [](let const& xs) { - return car(xs).is(); + return xs[0].is(); }); - #define DEFINE(SYMBOL, COMPARE) \ - library.define(#SYMBOL, [](let const& xs) \ - { \ - return std::adjacent_find( \ - std::begin(xs), std::end(xs), [](let const& a, let const& b) \ - { \ - return not apply_arithmetic(a, b).as(); \ - }) == std::end(xs); \ - }) + library.define("=", [](let const& xs) + { + return std::adjacent_find(std::begin(xs), std::end(xs), not_equals) == std::end(xs); + }); - DEFINE(= , equal_to ); - DEFINE(< , less ); - DEFINE(<=, less_equal ); - DEFINE(> , greater ); - DEFINE(>=, greater_equal); + library.define("<", [](let const& xs) + { + return std::adjacent_find(std::begin(xs), std::end(xs), greater_than_or_equals) == std::end(xs); + }); - #undef DEFINE + library.define("<=", [](let const& xs) + { + return std::adjacent_find(std::begin(xs), std::end(xs), greater_than) == std::end(xs); + }); + + library.define(">", [](let const& xs) + { + return std::adjacent_find(std::begin(xs), std::end(xs), less_than_or_equals) == std::end(xs); + }); + + library.define(">=", [](let const& xs) + { + return std::adjacent_find(std::begin(xs), std::end(xs), less_than) == std::end(xs); + }); library.define("+", [](let const& xs) { - return std::accumulate(std::begin(xs), std::end(xs), e0, plus()); + return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); }); library.define("*", [](let const& xs) { - return std::accumulate(std::begin(xs), std::end(xs), e1, multiplies()); + return std::accumulate(std::begin(xs), std::end(xs), e1, std::multiplies()); }); - #define DEFINE(SYMBOL, FUNCTION, BASIS) \ - library.define(SYMBOL, [](let const& xs) \ - { \ - return cdr(xs).is() ? std::accumulate(std::next(std::begin(xs)), std::end(xs), car(xs), [](auto&& a, auto&& b) \ - { \ - return FUNCTION()(a, b); \ - }) \ - : FUNCTION()(BASIS, car(xs)); \ - }) + library.define("-", [](let const& xs) + { + if (cdr(xs).is()) + { + return std::accumulate(std::next(std::begin(xs)), std::end(xs), xs[0], std::minus()); + } + else + { + return e0 - xs[0]; + } + }); - DEFINE("-", minus , e0); - DEFINE("/", divides, e1); - DEFINE("%", modulus, e1); + library.define("/", [](let const& xs) + { + if (cdr(xs).is()) + { + return std::accumulate(std::next(std::begin(xs)), std::end(xs), xs[0], std::divides()); + } + else + { + return e1 / xs[0]; + } + }); - #undef DEFINE + library.define("%", [](let const& xs) + { + return xs[0] % xs[1]; + }); library.define("ratio-numerator", [](let const& xs) { @@ -595,58 +625,60 @@ inline namespace kernel library.define("floor", [](let const& xs) { - return apply_arithmetic(car(xs)); + return floor(xs[0]); }); library.define("ceiling", [](let const& xs) { - return apply_arithmetic(car(xs)); + return ceil(xs[0]); }); library.define("truncate", [](let const& xs) { - return apply_arithmetic(car(xs)); + return trunc(xs[0]); }); library.define("round", [](let const& xs) { - return apply_arithmetic(car(xs)); + return round(xs[0]); }); library.define("exact-integer-square-root", [](let const& xs) { - auto&& [s, r] = exact_integer_sqrt(car(xs).as()); - return cons(make(s), make(r)); + auto&& [s, r] = exact_integer_sqrt(xs[0].as()); + + return cons(make(std::forward(s)), + make(std::forward(r))); }); library.define("expt", [](let const& xs) { - return apply_arithmetic(car(xs), cadr(xs)); + return pow(xs[0], xs[1]); }); library.define("exact", [](let const& xs) { - return apply_arithmetic(car(xs)); + return exact(xs[0]); }); library.define("inexact", [](let const& xs) { - return apply_arithmetic(car(xs)); + return inexact(xs[0]); }); library.define("char->integer", [](let const& xs) { - return make(car(xs).as().codepoint); + return make(xs[0].as().codepoint); }); library.define("string->number", [](let const& xs) { - return string_to_number(car(xs).as(), - cdr(xs).is() ? cadr(xs).as() : 10); + return make_number(xs[0].as(), + cdr(xs).is() ? xs[1].as() : 10); }); }); - define_library("(meevax pair)", [](library & library) + define("(meevax pair)", [](library & library) { library.define("pair?", [](let const& xs) { @@ -696,7 +728,7 @@ inline namespace kernel library.define("set-cdr!", [](auto&& xs) { return cdar(xs) = cadr(xs); }); }); - define_library("(meevax port)", [](library & library) + define("(meevax port)", [](library & library) { library.define("input-port?", [](let const& xs) { @@ -781,7 +813,7 @@ inline namespace kernel }); }); - define_library("(meevax read)", [](library & library) + define("(meevax read)", [](library & library) { library.define("get-char", [](let const& xs) { @@ -857,7 +889,7 @@ inline namespace kernel }); }); - define_library("(meevax string)", [](library & library) + define("(meevax string)", [](library & library) { library.define("string?", [](let const& xs) { @@ -1005,11 +1037,11 @@ inline namespace kernel }) == std::end(xs); \ } - library.define("string=?", STRING_COMPARE(equal_to )); - library.define("string("string<=?", STRING_COMPARE(less_equal )); - library.define("string>?", STRING_COMPARE(greater )); - library.define("string>=?", STRING_COMPARE(greater_equal)); + 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 @@ -1020,20 +1052,7 @@ inline namespace kernel library.define("number->string", [](let const& xs) { - switch (cdr(xs).is() ? cadr(xs).as() : 10) - { - case 2: - return apply_arithmetic>(car(xs)); - - case 8: - return apply_arithmetic>(car(xs)); - - case 10: default: - return apply_arithmetic>(car(xs)); - - case 16: - return apply_arithmetic>(car(xs)); - } + return number_to_string(xs[0], cdr(xs).is() ? xs[1].as() : 10); }); library.define("list->string", [](let const& xs) @@ -1104,7 +1123,7 @@ inline namespace kernel }); }); - define_library("(meevax symbol)", [](library & library) + define("(meevax symbol)", [](library & library) { library.define("symbol?", [](let const& xs) { @@ -1113,9 +1132,11 @@ inline namespace kernel library.define("string->symbol", [](let const& xs) { - return string_to_symbol(car(xs).as()); + return make_symbol(car(xs).as()); }); + using syntactic_closure = environment::syntactic_closure; + library.define("identifier->symbol", [](let const& xs) { if (let const& x = car(xs); x.is()) @@ -1129,7 +1150,39 @@ inline namespace kernel }); }); - define_library("(meevax vector)", [](library & library) + define("(meevax system)", [](library & library) + { + library.define("get-environment-variable", [](let const& xs) + { + if (auto s = std::getenv(static_cast(xs[0].as()).c_str())) + { + return make(s); + } + else + { + return f; + } + }); + + library.define("get-environment-variables", [](let const&) + { + let alist = unit; + + for (auto iter = environ; *iter; ++iter) + { + if (auto const position = std::string_view(*iter).find_first_of("="); position != std::string::npos) + { + alist = cons(cons(make(std::string(*iter, position)), + make(std::string(*iter + position + 1))), + alist); + } + } + + return alist; + }); + }); + + define("(meevax vector)", [](library & library) { library.define("vector?", [](let const& xs) { @@ -1305,7 +1358,133 @@ inline namespace kernel }); }); - define_library("(meevax version)", [](library & library) + define("(meevax vector homogeneous)", [](library & library) + { + #define DEFINE_HOMOGENEOUS_VECTOR(TAG) \ + library.define(#TAG "vector?", [](let const& xs) \ + { \ + return xs[0].is(); \ + }); \ + \ + library.define("make-" #TAG "vector", [](let const& xs) \ + { \ + return make(xs[0].as(), tail(xs, 1).is() ? xs[1] : unspecified); \ + }); \ + \ + library.define(#TAG "vector", [](let const& xs) \ + { \ + return make(xs); \ + }); \ + \ + library.define(#TAG "vector-length", [](let const& xs) \ + { \ + return make(xs[0].as().values.size()); \ + }); \ + \ + library.define(#TAG "vector-ref", [](let const& xs) \ + { \ + return TAG##vector::output_cast(xs[0].as().values[xs[1].as()]); \ + }); \ + \ + library.define(#TAG "vector-set!", [](let const& xs) \ + { \ + xs[0].as().values[xs[1].as()] = TAG##vector::input_cast(xs[2]); \ + }); \ + \ + library.define(#TAG "vector-copy", [](let const& xs) \ + { \ + return make(xs[0].as(), \ + tail(xs, 1).is() ? xs[1].as() : std::size_t(), \ + tail(xs, 2).is() ? xs[2].as() : xs[0].as().values.size()); \ + }); \ + \ + library.define(#TAG "vector-copy!", [](let const& xs) \ + { \ + auto copy = [](auto&& to, auto&& at, auto&& from, auto&& start, auto&& end) \ + { \ + to[std::slice(at, end - start, 1)] = from[std::slice(start, end - start, 1)]; \ + }; \ + \ + copy(xs[0].as().values, \ + xs[1].as(), \ + xs[2].as().values, \ + tail(xs, 3).is() ? xs[3].as() : 0, \ + tail(xs, 4).is() ? xs[4].as() : xs[2].as().values.size()); \ + }); \ + \ + library.define(#TAG "vector-append", [](let const& xs) \ + { \ + return make(xs[0].as(), \ + xs[1].as()); \ + }); \ + \ + library.define(#TAG "vector->list", [](let const& xs) \ + { \ + auto list = [](auto&& v, auto&& a, auto&& b) \ + { \ + auto xcons = [](auto&& x, auto&& y) \ + { \ + return cons(TAG##vector::output_cast(y), x); \ + }; \ + \ + return reverse(std::accumulate(std::next(std::begin(v), a), \ + std::next(std::begin(v), b), unit, xcons)); \ + }; \ + \ + return list(xs[0].as().values, \ + tail(xs, 1).is() ? xs[1].as() : 0, \ + tail(xs, 2).is() ? xs[2].as() : xs[0].as().values.size()); \ + }); \ + \ + library.define("list->" #TAG "vector", [](let const& xs) \ + { \ + return make(xs[0]); \ + }) + + DEFINE_HOMOGENEOUS_VECTOR(f32); + DEFINE_HOMOGENEOUS_VECTOR(f64); + DEFINE_HOMOGENEOUS_VECTOR(s8); + DEFINE_HOMOGENEOUS_VECTOR(s16); + DEFINE_HOMOGENEOUS_VECTOR(s32); + DEFINE_HOMOGENEOUS_VECTOR(s64); + DEFINE_HOMOGENEOUS_VECTOR(u8); + DEFINE_HOMOGENEOUS_VECTOR(u16); + DEFINE_HOMOGENEOUS_VECTOR(u32); + DEFINE_HOMOGENEOUS_VECTOR(u64); + + library.define("u8vector->string", [](let const& xs) + { + auto input = std::stringstream(); + + std::for_each(std::next(std::begin(xs[0].as().values), tail(xs, 1).is() ? xs[1].as() : 0), + std::next(std::begin(xs[0].as().values), tail(xs, 2).is() ? xs[2].as() : xs[0].as().values.size()), + [&](auto const& x) + { + input << x; + }); + + auto output = string(); + + while (input.peek() != std::char_traits::eof()) + { + output.codepoints.emplace_back(get_codepoint(input)); + } + + return make(output); + }); + + library.define("string->u8vector", [](let const& xs) + { + auto convert = [](std::string const& s) + { + return make(reinterpret_cast(s.data()), s.size()); + }; + + return convert(xs[0].as()); + }); + }); + + define("(meevax version)", [](library & library) { library.define("features", []() { @@ -1313,7 +1492,7 @@ inline namespace kernel }); }); - define_library("(meevax write)", [](library & library) + define("(meevax write)", [](library & library) { library.define("put-char", [](let const& xs) { @@ -1338,57 +1517,16 @@ inline namespace kernel auto boot_loader = environment(); - if (auto input = std::stringstream(std::string(basis)); input) + for (auto&& each : basis()) { - while (not input.eof()) + if (std::stringstream input { each }; input) { - boot_loader.evaluate(boot_loader.read(input)); - } - } - } - - auto library::evaluate(object const& declaration) -> void - { - if (declaration[0].is() and declaration[0].as() == "export") - { - for (let const& form : cdr(declaration)) - { - declare(form); - } - } - else if (declaration[0].is() and declaration[0].as() == "begin") - { - for (let const& command_or_definition : cdr(declaration)) - { - evaluate(command_or_definition); - } - } - else - { - environment::evaluate(declaration); // Non-standard extension. - } - } - - auto library::resolve() -> object const& - { - if (not declarations.is()) - { - for (let const& declaration : declarations) - { - evaluate(declaration); + while (not input.eof()) + { + boot_loader.evaluate(boot_loader.read(input)); + } } - - declarations = unit; } - - return subset; } - - auto operator <<(std::ostream & os, library const& library) -> std::ostream & - { - return os << library.global(); - } - - std::map libraries {}; } // namespace kernel } // namespace meevax diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index 450e6c168..ac611c290 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -14,7 +14,10 @@ limitations under the License. */ +#include // std::unique_ptr + #include +#include namespace meevax { @@ -37,19 +40,19 @@ inline namespace kernel auto operator * (exact_integer const& a, ratio const& b) -> ratio { ratio q; mpq_mul(q.value, ratio(a).value, b.value); return q; } auto operator / (exact_integer const& a, ratio const& b) -> ratio { ratio q; mpq_div(q.value, ratio(a).value, b.value); return q; } auto operator % (exact_integer const& , ratio const& ) -> ratio { throw std::invalid_argument("unsupported operation"); } - auto operator ==(exact_integer const& a, ratio const& b) -> bool { return mpq_cmp_z(b.value, a.value) == 0; } - auto operator !=(exact_integer const& a, ratio const& b) -> bool { return mpq_cmp_z(b.value, a.value) != 0; } - auto operator < (exact_integer const& a, ratio const& b) -> bool { return mpq_cmp_z(b.value, a.value) > 0; } - auto operator <=(exact_integer const& a, ratio const& b) -> bool { return mpq_cmp_z(b.value, a.value) >= 0; } - auto operator > (exact_integer const& a, ratio const& b) -> bool { return mpq_cmp_z(b.value, a.value) < 0; } - auto operator >=(exact_integer const& a, ratio const& b) -> bool { return mpq_cmp_z(b.value, a.value) <= 0; } + auto operator ==(exact_integer const& a, ratio const& b) -> bool { return 0 == mpq_cmp_z(b.value, a.value); } + auto operator !=(exact_integer const& a, ratio const& b) -> bool { return 0 != mpq_cmp_z(b.value, a.value); } + auto operator < (exact_integer const& a, ratio const& b) -> bool { return 0 < mpq_cmp_z(b.value, a.value); } + auto operator <=(exact_integer const& a, ratio const& b) -> bool { return 0 <= mpq_cmp_z(b.value, a.value); } + auto operator > (exact_integer const& a, ratio const& b) -> bool { return 0 > mpq_cmp_z(b.value, a.value); } + auto operator >=(exact_integer const& a, ratio const& b) -> bool { return 0 >= mpq_cmp_z(b.value, a.value); } auto operator + (exact_integer const& a, float b) -> float { return inexact_cast(a) + b; } auto operator - (exact_integer const& a, float b) -> float { return inexact_cast(a) - b; } auto operator * (exact_integer const& a, float b) -> float { return inexact_cast(a) * b; } auto operator / (exact_integer const& a, float b) -> float { return inexact_cast(a) / b; } auto operator % (exact_integer const& a, float b) -> float { return std::remainder(inexact_cast(a), b); } - auto operator ==(exact_integer const& a, float b) -> bool { return std::invoke(equal_to(), inexact_cast(a), b); } + auto operator ==(exact_integer const& a, float b) -> bool { return inexact_equals(inexact_cast(a), b); } auto operator !=(exact_integer const& a, float b) -> bool { return not (a == b); } auto operator < (exact_integer const& a, float b) -> bool { return inexact_cast(a) < b; } auto operator <=(exact_integer const& a, float b) -> bool { return inexact_cast(a) <= b; } @@ -109,7 +112,7 @@ inline namespace kernel auto operator * (ratio const& a, float b) -> float { return inexact_cast(a) * b; } auto operator / (ratio const& a, float b) -> float { return inexact_cast(a) / b; } auto operator % (ratio const& a, float b) -> float { return std::remainder(inexact_cast(a), b); } - auto operator ==(ratio const& a, float b) -> bool { return std::invoke(equal_to(), inexact_cast(a), b); } + auto operator ==(ratio const& a, float b) -> bool { return inexact_equals(inexact_cast(a), b); } auto operator !=(ratio const& a, float b) -> bool { return not (a == b); } auto operator < (ratio const& a, float b) -> bool { return inexact_cast(a) < b; } auto operator <=(ratio const& a, float b) -> bool { return inexact_cast(a) <= b; } @@ -121,7 +124,7 @@ inline namespace kernel auto operator * (ratio const& a, double b) -> double { return inexact_cast(a) * b; } auto operator / (ratio const& a, double b) -> double { return inexact_cast(a) / b; } auto operator % (ratio const& a, double b) -> double { return std::remainder(inexact_cast(a), b); } - auto operator ==(ratio const& a, double b) -> bool { return std::invoke(equal_to(), inexact_cast(a), b); } + auto operator ==(ratio const& a, double b) -> bool { return inexact_equals(inexact_cast(a), b); } auto operator !=(ratio const& a, double b) -> bool { return not (a == b); } auto operator < (ratio const& a, double b) -> bool { return inexact_cast(a) < b; } auto operator <=(ratio const& a, double b) -> bool { return inexact_cast(a) <= b; } @@ -145,7 +148,7 @@ inline namespace kernel auto operator * (float a, exact_integer const& b) -> float { return a * inexact_cast(b); } auto operator / (float a, exact_integer const& b) -> float { return a / inexact_cast(b); } auto operator % (float a, exact_integer const& b) -> float { return std::remainder(a, inexact_cast(b)); } - auto operator ==(float a, exact_integer const& b) -> bool { return std::invoke(equal_to(), a, inexact_cast(b)); } + auto operator ==(float a, exact_integer const& b) -> bool { return inexact_equals(a, inexact_cast(b)); } auto operator !=(float a, exact_integer const& b) -> bool { return not (a == b); } auto operator < (float a, exact_integer const& b) -> bool { return a < inexact_cast(b); } auto operator <=(float a, exact_integer const& b) -> bool { return a <= inexact_cast(b); } @@ -157,7 +160,7 @@ inline namespace kernel auto operator * (float a, ratio const& b) -> float { return a * inexact_cast(b); } auto operator / (float a, ratio const& b) -> float { return a / inexact_cast(b); } auto operator % (float a, ratio const& b) -> float { return std::remainder(a, inexact_cast(b)); } - auto operator ==(float a, ratio const& b) -> bool { return std::invoke(equal_to(), a, inexact_cast(b)); } + auto operator ==(float a, ratio const& b) -> bool { return inexact_equals(a, inexact_cast(b)); } auto operator !=(float a, ratio const& b) -> bool { return not (a == b); } auto operator < (float a, ratio const& b) -> bool { return a < inexact_cast(b); } auto operator <=(float a, ratio const& b) -> bool { return a <= inexact_cast(b); } @@ -193,7 +196,7 @@ inline namespace kernel auto operator * (double a, ratio const& b) -> double { return a * inexact_cast(b); } auto operator / (double a, ratio const& b) -> double { return a / inexact_cast(b); } auto operator % (double a, ratio const& b) -> double { return std::remainder(a, inexact_cast(b)); } - auto operator ==(double a, ratio const& b) -> bool { return std::invoke(equal_to(), a, inexact_cast(b)); } + auto operator ==(double a, ratio const& b) -> bool { return inexact_equals(a, inexact_cast(b)); } auto operator !=(double a, ratio const& b) -> bool { return not (a == b); } auto operator < (double a, ratio const& b) -> bool { return a < inexact_cast(b); } auto operator <=(double a, ratio const& b) -> bool { return a <= inexact_cast(b); } @@ -217,7 +220,7 @@ inline namespace kernel auto operator * (complex const& a, complex const& b) -> complex { return complex(a.real() * b.real() - a.imag() * b.imag(), a.imag() * b.real() + a.real() * b.imag()); } auto operator / (complex const& a, complex const& b) -> complex { auto x = a.real() * b.real() + a.imag() * b.imag(); auto y = a.imag() * b.real() - a.real() * b.imag(); auto d = b.real() * b.real() + b.imag() * b.imag(); return complex(x / d, y / d); } auto operator % (complex const& , complex const& ) -> complex { throw std::invalid_argument("unsupported operation"); } - auto operator ==(complex const& a, complex const& b) -> bool { return apply_arithmetic(a.real(), b.real()).as() and apply_arithmetic(a.imag(), b.imag()).as(); } + auto operator ==(complex const& a, complex const& b) -> bool { return equals(a.real(), b.real()) and equals(a.imag(), b.imag()); } auto operator !=(complex const& a, complex const& b) -> bool { return not (a == b); } auto operator < (complex const& , complex const& ) -> bool { throw std::invalid_argument("unsupported operation"); } auto operator <=(complex const& , complex const& ) -> bool { throw std::invalid_argument("unsupported operation"); } @@ -272,10 +275,548 @@ inline namespace kernel auto operator > (complex const& , exact_integer const& ) -> bool { throw std::invalid_argument("unsupported operation"); } auto operator >=(complex const& , exact_integer const& ) -> bool { throw std::invalid_argument("unsupported operation"); } - auto operator + (object const& x, object const& y) -> object { return apply_arithmetic(x, y); } - auto operator - (object const& x, object const& y) -> object { return apply_arithmetic(x, y); } - auto operator * (object const& x, object const& y) -> object { return apply_arithmetic(x, y); } - auto operator / (object const& x, object const& y) -> object { return apply_arithmetic(x, y); } - auto operator % (object const& x, object const& y) -> object { return apply_arithmetic(x, y); } + template + auto canonicalize(T&& x) -> decltype(auto) + { + if constexpr (std::is_same_v, object>) + { + return std::forward(x); + } + else if constexpr (std::is_same_v, complex>) + { + return x.canonicalize(); + } + else if constexpr (std::is_same_v, ratio>) + { + return x.denominator() == 1 ? make(x.numerator()) : make(std::forward(x)); + } + else + { + return make(std::forward(x)); + } + } + + template + auto apply([[maybe_unused]] F f, object const& x) -> object + { + using Ts = std::tuple; + + if constexpr (I < std::tuple_size_v) + { + using T = std::tuple_element_t; + + if (x.is()) + { + return canonicalize(f(x.as())); + } + else + { + return apply(f, x); + } + } + else + { + throw std::domain_error("not an number"); + } + } + + template + auto apply([[maybe_unused]] F f, object const& x, object const& y) -> object + { + using Ts = combination; + + if constexpr (I < std::tuple_size_v) + { + using T = std::tuple_element_t<0, std::tuple_element_t>; + using U = std::tuple_element_t<1, std::tuple_element_t>; + + if (x.is() and y.is()) + { + return canonicalize(f(x.as(), y.as())); + } + else + { + return apply(f, x, y); + } + } + else + { + throw std::domain_error("not an number"); + } + } + + template + auto test([[maybe_unused]] F f, object const& x) -> bool + { + using Ts = std::tuple; + + if constexpr (I < std::tuple_size_v) + { + using T = std::tuple_element_t; + + return x.is() ? f(x.as()) : test(f, x); + } + else + { + return false; + } + } + + template + auto test([[maybe_unused]] F f, object const& x, object const& y) -> bool + { + using Ts = combination; + + if constexpr (I < std::tuple_size_v) + { + using T = std::tuple_element_t<0, std::tuple_element_t>; + using U = std::tuple_element_t<1, std::tuple_element_t>; + + return x.is() and y.is() ? f(x.as(), y.as()) : test(f, x, y); + } + else + { + return false; + } + } + + auto operator +(object const& x, object const& y) -> object + { + return apply(std::plus(), x, y); + } + + auto operator -(object const& x, object const& y) -> object + { + return apply(std::minus(), x, y); + } + + auto operator *(object const& x, object const& y) -> object + { + return apply(std::multiplies(), x, y); + } + + auto operator /(object const& x, object const& y) -> object + { + return apply(std::divides(), x, y); + } + + auto operator % (object const& x, object const& y) -> object + { + auto f = [](auto&& x, auto&& y) + { + using T = std::decay_t; + using U = std::decay_t; + + if constexpr (std::is_floating_point_v and + std::is_floating_point_v) + { + return std::fmod(x, y); + } + else + { + return x % y; + } + }; + + return apply(f, x, y); + } + +inline namespace number +{ + auto equals(object const& x, object const& y) -> bool + { + auto f = [](auto&&... xs) + { + return inexact_equals(std::forward(xs)...); + }; + + return test(f, x, y); + } + + auto not_equals(object const& x, object const& y) -> bool + { + return not equals(x, y); + } + + auto less_than(object const& x, object const& y) -> bool + { + return test(std::less(), x, y); + } + + auto less_than_or_equals(object const& x, object const& y) -> bool + { + return not greater_than(x, y); + } + + auto greater_than(object const& x, object const& y) -> bool + { + return test(std::greater(), x, y); + } + + auto greater_than_or_equals(object const& x, object const& y) -> bool + { + return not less_than(x, y); + } + + auto exact(object const& x) -> object + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + return complex(exact(x.real()), + exact(x.imag())); + } + else if constexpr (std::is_floating_point_v) + { + return ratio(std::forward(x)); + } + else + { + return std::forward(x); + } + }; + + return apply(f, x); + } + + auto inexact(object const& x) -> object + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + return complex(inexact(x.real()), + inexact(x.imag())); + } + else + { + return inexact_cast(std::forward(x)); + } + }; + + return apply(f, x); + } + + auto is_complex(object const& x) -> bool + { + auto f = [](auto&&) + { + return true; + }; + + return test(f, x); + } + + auto is_real(object const& x) -> bool + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + return equals(x.imag(), e0); + } + else + { + return true; + } + }; + + return test(f, x); + } + + auto is_rational(object const& x) -> bool + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_floating_point_v) + { + return not std::isnan(x) and + not std::isinf(x); + } + else + { + return std::is_same_v or + std::is_same_v; + } + }; + + return test(f, x); + } + + auto is_integer(object const& x) -> bool + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + return equals(x.imag(), e0) and is_integer(x.real()); + } + else if constexpr (std::is_floating_point_v) + { + return x == std::trunc(x); + } + else if constexpr (std::is_same_v) + { + return x.denominator() == 1; + } + else + { + return std::is_same_v; + } + }; + + return test(f, x); + } + + auto is_finite(object const& x) -> bool + { + return not is_infinite(x); + } + + auto is_infinite(object const& x) -> bool + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + return is_infinite(x.real()) or + is_infinite(x.imag()); + } + else if constexpr (std::is_floating_point_v) + { + return std::isinf(std::forward(x)); + } + else + { + return false; + } + }; + + return test(f, x); + } + + auto is_nan(object const& x) -> bool + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + return is_nan(x.real()) or + is_nan(x.imag()); + } + else if constexpr (std::is_floating_point_v) + { + return std::isnan(std::forward(x)); + } + else + { + return false; + } + }; + + return test(f, x); + } + + auto sqrt(object const& x) -> object + { + auto f = [](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_same_v) + { + auto const z = std::sqrt(inexact_cast(std::forward(x))); + + return complex(make(z.real()), + make(z.imag())); + } + else + { + auto sqrt = [](auto&& x) + { + if constexpr (std::is_same_v) + { + auto const [s, r] = exact_integer_sqrt(x); + + return r == 0 ? make(s) : make(std::sqrt(inexact_cast(x))); + } + else + { + return make(std::sqrt(inexact_cast(std::forward(x)))); + } + }; + + return x < exact_integer(0) ? make(e0, sqrt(exact_integer(0) - x)) + : sqrt(x); + } + }; + + return apply(f, x); + } + + auto pow(object const& x, object const& y) -> object + { + auto f = [](auto&& x, auto&& y) + { + using T = std::decay_t; + using U = std::decay_t; + + if constexpr (std::is_same_v or + std::is_same_v) + { + auto const z = std::pow(inexact_cast(std::forward(x)), + inexact_cast(std::forward(y))); + + return complex(make(z.real()), + make(z.imag())); + } + else if constexpr (std::is_same_v and + std::is_same_v) + { + exact_integer result {}; + mpz_pow_ui(result.value, x.value, static_cast(y)); + return result; + } + else + { + return std::pow(inexact_cast(std::forward(x)), + inexact_cast(std::forward(y))); + } + }; + + return apply(f, x, y); + } + + #define DEFINE(ROUND) \ + auto ROUND(object const& x) -> object \ + { \ + auto f = [](auto&& x) \ + { \ + using T = std::decay_t; \ + \ + if constexpr (std::is_floating_point_v) \ + { \ + return std::ROUND(inexact_cast(std::forward(x))); \ + } \ + else if constexpr (std::is_same_v) \ + { \ + return exact_integer(std::ROUND(inexact_cast(std::forward(x)))); \ + } \ + else if constexpr (std::is_same_v) \ + { \ + return std::forward(x); \ + } \ + else \ + { \ + return complex(ROUND(x.real()), \ + ROUND(x.imag())); \ + } \ + }; \ + \ + return apply(f, x); \ + } \ + static_assert(true) + + DEFINE(floor); + DEFINE(ceil); + DEFINE(trunc); + DEFINE(round); + + #undef DEFINE + + #define DEFINE(CMATH) \ + auto CMATH(object const& x) -> object \ + { \ + auto f = [](auto&& x) \ + { \ + using T = std::decay_t; \ + \ + if constexpr (std::is_same_v) \ + { \ + auto const z = std::CMATH(inexact_cast(std::forward(x))); \ + \ + return complex(make(z.real()), \ + make(z.imag())); \ + } \ + else \ + { \ + return std::CMATH(inexact_cast(std::forward(x))); \ + } \ + }; \ + \ + return apply(f, x); \ + } \ + static_assert(true) + + DEFINE(sin); DEFINE(asin); DEFINE(sinh); DEFINE(asinh); + DEFINE(cos); DEFINE(acos); DEFINE(cosh); DEFINE(acosh); + DEFINE(tan); DEFINE(atan); DEFINE(tanh); DEFINE(atanh); + + DEFINE(exp); + DEFINE(log); + + #undef DEFINE + + auto atan(object const& x, object const& y) -> object + { + auto f = [](auto&& x, auto&& y) + { + using T = std::decay_t; + using U = std::decay_t; + + if constexpr (std::is_same_v or + std::is_same_v) + { + throw std::invalid_argument("unsupported operation"); + return e0; // dummy return value. + } + else + { + return std::atan2(inexact_cast(std::forward(x)), + inexact_cast(std::forward(y))); + } + }; + + return apply(f, x, y); + } + + auto number_to_string(object const& x, int radix) -> object + { + auto f = [radix](auto&& x) + { + using T = std::decay_t; + + if constexpr (std::is_floating_point_v) + { + return string("TODO"); + } + else if constexpr (std::is_same_v) + { + return string(std::unique_ptr(mpz_get_str(nullptr, radix, x.value)).get()); + } + else + { + return string("TODO"); + } + }; + + return apply(f, x); + } +} // namespace number } // namespace kernel } // namespace meevax diff --git a/src/kernel/pair.cpp b/src/kernel/pair.cpp index 243c572d7..e0bebfa58 100644 --- a/src/kernel/pair.cpp +++ b/src/kernel/pair.cpp @@ -46,9 +46,9 @@ inline namespace kernel return 0 < k ? second[--k] : first; } - auto label(object const& x, object const& y) -> object const& + auto find_circulation(object const& x, object const& y) -> object const& { - if (x.is() and cdr(x).is() and (cddr(x) == cdr(y) or label(cddr(x), cdr(y)))) + if (x.is() and cdr(x).is() and (cddr(x) == cdr(y) or find_circulation(cddr(x), cdr(y)))) { return cdddr(x); } @@ -58,9 +58,9 @@ inline namespace kernel } } - auto label(pair const& x) + auto find_circulation(pair const& x) { - if (cdr(x).is() and (cddr(x) == cdr(x) or label(cddr(x), cdr(x)))) + if (cdr(x).is() and (cddr(x) == cdr(x) or find_circulation(cddr(x), cdr(x)))) { return cdddr(x); } @@ -72,25 +72,17 @@ inline namespace kernel auto write_simple(std::ostream & os, pair const& datum) -> std::ostream & { - os << magenta("("); + write_simple(os << magenta("("), car(datum)); - write_simple(os, car(datum)); - - for (auto iter = std::begin(cdr(datum)); iter != unit; ++iter) + for (let xs = cdr(datum); xs != unit; xs = cdr(xs)) { - if (iter.get().is()) + if (xs.is()) { - os << " "; - - write_simple(os, *iter); + write_simple(os << " ", car(xs)); } - else // iter is the last element of dotted-list. + else // xs is the last element of dotted-list. { - os << magenta(" . "); - - write_simple(os, iter.get()); - - return os << magenta(")"); + return write_simple(os << magenta(" . "), xs) << magenta(")"); } } @@ -104,15 +96,15 @@ inline namespace kernel auto operator <<(std::ostream & os, pair const& datum) -> std::ostream & { - if (let const& end = label(datum)) + if (let const& circulation = find_circulation(datum)) { - auto n = reinterpret_cast(end.get()); + auto n = reinterpret_cast(circulation.get()); os << magenta("#", n, "=(") << car(datum); - for (auto iter = std::begin(cdr(datum)); iter != end; ++iter) + for (auto xs = cdr(datum); xs != circulation; xs = cdr(xs)) { - os << " " << *iter; + os << " " << car(xs); } return os << magenta(" . #", n, "#)"); diff --git a/src/kernel/ratio.cpp b/src/kernel/ratio.cpp index b7f0a69be..bb299af19 100644 --- a/src/kernel/ratio.cpp +++ b/src/kernel/ratio.cpp @@ -63,8 +63,6 @@ inline namespace kernel ratio::ratio(std::string const& token, int radix) { - // std::regex static const pattern { "([+-]?[0-9a-f]+)/([0-9a-f]+)" }; - if (mpq_init(value); mpq_set_str(value, token.c_str(), radix)) { mpq_clear(value); diff --git a/src/kernel/reader.cpp b/src/kernel/reader.cpp index f7d2b38fe..a363c8d5a 100644 --- a/src/kernel/reader.cpp +++ b/src/kernel/reader.cpp @@ -15,6 +15,7 @@ */ #include +#include #include #include @@ -96,6 +97,18 @@ inline namespace kernel return codepoint; } + auto get_digits(std::istream & input) -> std::string + { + auto digits = std::string(); + + while (std::isdigit(input.peek())) + { + digits.push_back(input.get()); + } + + return std::empty(digits) ? "0" : digits; + } + auto get_token(std::istream & is) -> std::string { auto token = std::string(); @@ -243,32 +256,54 @@ inline namespace kernel throw read_error(make("An end of file is encountered after the beginning of an object's external representation, but the external representation is incomplete and therefore not parsable")); } - auto string_to_integer(std::string const& token, int radix) -> object + auto circulate(object const& xs, object const& x, std::string const& n) -> void + { + if (xs.is()) + { + circulate(car(xs), x, n); + + if (cdr(xs).is() and cdr(xs).as().n == n) + { + cdr(xs) = x; + } + else + { + circulate(cdr(xs), x, n); + } + } + } + + auto circulate(object const& xs, std::string const& n) -> void + { + return circulate(xs, xs, n); + } + + auto make_integer(std::string const& token, int radix) -> object { return make(token, radix); } - auto string_to_rational(std::string const& token, int radix) -> object + auto make_rational(std::string const& token, int radix) -> object { try { - return string_to_integer(token, radix); + return make_integer(token, radix); } - catch (...) + catch (std::invalid_argument const&) { return make(ratio(token, radix)); } } - auto string_to_real(std::string const& token, int radix) -> object + auto make_real(std::string const& token, int radix) -> object { try { - return string_to_rational(token, radix); + return make_rational(token, radix); } - catch (...) + catch (std::invalid_argument const&) { - std::unordered_map static const constants + std::unordered_map static const constants { // R7RS 7.1.1. Lexical structure { "+inf.0", +std::numeric_limits::infinity() }, @@ -294,7 +329,7 @@ inline namespace kernel { "fl-1/sqrt-2", M_SQRT1_2 }, }; - std::regex static const pattern { R"(([+-]?(?:\d+\.?|\d*\.\d+))([DEFLSdefls][+-]?\d+)?)" }; + auto static const pattern = std::regex(R"(([+-]?(?:\d+\.?|\d*\.\d+))([DEFLSdefls][+-]?\d+)?)"); if (auto iter = constants.find(token); iter != std::end(constants)) { @@ -311,25 +346,25 @@ inline namespace kernel } } - auto string_to_complex(std::string const& token, int radix) -> object + auto make_complex(std::string const& token, int radix) -> object { try { - return string_to_real(token, radix); + return make_real(token, radix); } - catch (...) + catch (std::invalid_argument const&) { return make(complex(token, radix)); } } - auto string_to_number(std::string const& token, int radix) -> object + auto make_number(std::string const& token, int radix) -> object { try { - return string_to_complex(token, radix); + return make_complex(token, radix); } - catch (...) + catch (std::invalid_argument const&) { throw std::invalid_argument("not a number"); } diff --git a/src/kernel/symbol.cpp b/src/kernel/symbol.cpp index 3fc16427e..61744b94b 100644 --- a/src/kernel/symbol.cpp +++ b/src/kernel/symbol.cpp @@ -24,45 +24,49 @@ inline namespace kernel { auto operator +(symbol const& a, symbol const& b) -> std::string { - return a.std_string + b.std_string; + return a.name + b.name; } - auto operator ==(symbol const& a, symbol const& b) -> bool { return a.std_string == b.std_string; } - auto operator !=(symbol const& a, symbol const& b) -> bool { return a.std_string != b.std_string; } - auto operator < (symbol const& a, symbol const& b) -> bool { return a.std_string < b.std_string; } - auto operator <=(symbol const& a, symbol const& b) -> bool { return a.std_string <= b.std_string; } - auto operator > (symbol const& a, symbol const& b) -> bool { return a.std_string > b.std_string; } - auto operator >=(symbol const& a, symbol const& b) -> bool { return a.std_string >= b.std_string; } + auto operator ==(symbol const& a, symbol const& b) -> bool { return a.name == b.name; } + auto operator !=(symbol const& a, symbol const& b) -> bool { return a.name != b.name; } + auto operator < (symbol const& a, symbol const& b) -> bool { return a.name < b.name; } + auto operator <=(symbol const& a, symbol const& b) -> bool { return a.name <= b.name; } + auto operator > (symbol const& a, symbol const& b) -> bool { return a.name > b.name; } + auto operator >=(symbol const& a, symbol const& b) -> bool { return a.name >= b.name; } auto operator <<(std::ostream & os, symbol const& datum) -> std::ostream & { - if (datum.std_string.empty()) + if (datum.name.empty()) { return os << "||"; } - else if (auto iter = std::find_if(std::begin(datum.std_string), std::end(datum.std_string), [](auto c) + else if (auto iter = std::find_if(std::begin(datum.name), std::end(datum.name), [](auto c) { return std::iscntrl(c) or std::isspace(c); }); - iter != std::end(datum.std_string)) + iter != std::end(datum.name)) { - return os << cyan("#") << string(datum.std_string); + return os << cyan("#") << string(datum.name); } else { - return os << datum.std_string; + return os << datum.name; } } - std::unordered_map symbols; + auto symbols() -> std::unordered_map & + { + static auto symbols = std::unordered_map(); + return symbols; + } - auto string_to_symbol(std::string const& name) -> object const& + auto make_symbol(std::string const& name) -> object const& { - if (auto const iter = symbols.find(name); iter != std::end(symbols)) + if (auto const iter = symbols().find(name); iter != std::end(symbols())) { return iter->second; } - else if (auto const [iter, success] = symbols.emplace(name, make(name)); success) + else if (auto const [iter, success] = symbols().emplace(name, make(name)); success) { return iter->second; } diff --git a/src/kernel/vector.cpp b/src/kernel/vector.cpp index ddddcd047..867eb5dae 100644 --- a/src/kernel/vector.cpp +++ b/src/kernel/vector.cpp @@ -16,7 +16,6 @@ #include -#include #include #include #include @@ -46,9 +45,18 @@ inline namespace kernel std::begin(rhs.objects), std::end(rhs.objects), equal); } - auto operator <<(std::ostream & os, vector const& datum) -> std::ostream & + auto operator <<(std::ostream & output, vector const& datum) -> std::ostream & { - return os << magenta("#(") << for_each(datum.objects) << magenta(")"); + output << magenta("#("); + + auto whitespace = ""; + + for (auto const& each : datum.objects) + { + output << std::exchange(whitespace, " ") << each; + } + + return output << magenta(")"); } } // namespace kernel } // namespace meevax diff --git a/src/main.cpp b/src/main.cpp index 2717b60a9..a9d0fd715 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -14,7 +14,6 @@ limitations under the License. */ -#include #include auto main(int const argc, char const* const* const argv) -> int @@ -23,7 +22,7 @@ auto main(int const argc, char const* const* const argv) -> int return with_exception_handler([&]() { - library::boot(); + boot(); auto&& main = interaction_environment().as(); diff --git a/test/abandoned.ss b/test/abandoned.ss index 788810524..da83d7851 100644 --- a/test/abandoned.ss +++ b/test/abandoned.ss @@ -1,9 +1,9 @@ -(import (scheme base) +(import (meevax macro-transformer) + (scheme base) (scheme char) (scheme process-context) (scheme write) - (srfi 78) - (srfi 211 explicit-renaming)) + (srfi 78)) (define p1 (make-parameter 1)) diff --git a/test/chibi-basic.ss b/test/chibi-basic.ss index 2d6c8479b..1e1a59028 100644 --- a/test/chibi-basic.ss +++ b/test/chibi-basic.ss @@ -1,42 +1,34 @@ -(import (scheme base) +#| + Copyright (c) 2009-2018 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. +|# + +(import (meevax macro-transformer) + (scheme base) (scheme process-context) - (srfi 78) - (srfi 211 explicit-renaming)) + (srfi 78)) -; ---- Chibi-Scheme's Basic Tests ---------------------------------------------- -; -; NOTE -; Based on Chibi-Scheme's test codes at chibi-scheme/tests/basic/*.scm -; -; ORIGINAL LICENSE -; Copyright (c) 2009-2018 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. -; -; ------------------------------------------------------------------------------ - -; ==== test00-fact-3.scm ======================================================= +; ---- chibi-scheme/tests/basic/test00-fact-3.scm ------------------------------ (define (fact-aux x res) (if (= x 0) res @@ -47,7 +39,7 @@ (check (fact 3) => 6) -; ==== test01-apply.scm ======================================================== +; ---- chibi-scheme/tests/basic/test01-apply.scm ------------------------------- (define foo (lambda (a b c d e f g h) @@ -72,7 +64,7 @@ (check (apply foo 1 2 3 4 5 (list 6 7 8)) => 100) -; ==== test02-closure.scm ====================================================== +; ---- chibi-scheme/tests/basic/test02-closure.scm ----------------------------- (define (make-counter n) (lambda () @@ -95,7 +87,7 @@ (check (g) => 103) -; ==== test03-nested-closure.scm =============================================== +; ---- chibi-scheme/tests/basic/test03-nested-closure.scm ---------------------- (check ((lambda (a b) ((lambda (c d e) @@ -104,7 +96,7 @@ 3 5) => 11357) -; ==== test04-nested-let.scm =================================================== +; ---- chibi-scheme/tests/basic/test04-nested-let.scm -------------------------- (check (let ((a 3) (b 5)) @@ -114,14 +106,14 @@ (+ e (* c 1000) (* a 100) (* b 10) d))) => 11357) -; ==== test05-internal-define.scm ============================================== +; ---- chibi-scheme/tests/basic/test05-internal-define.scm --------------------- (check (let ((a 1000)) (define b (+ a 3)) (cons a b)) => '(1000 . 1003)) -; ==== test06-letrec.scm ======================================================= +; ---- chibi-scheme/tests/basic/test06-letrec.scm ------------------------------ (check (letrec ((add (lambda (a b) (+ a b)))) @@ -139,7 +131,7 @@ (odd? 1000))) => '(#t #f #f)) -; ==== test07-mutation.scm ===================================================== +; ---- chibi-scheme/tests/basic/test07-mutation.scm ---------------------------- (check (let ((a 3) (b 5)) @@ -150,7 +142,7 @@ (+ e (* c 1000) (* a 100) (* b 10) d))) => 11357) -; ==== test08-callcc.scm ======================================================= +; ---- chibi-scheme/tests/basic/test08-callcc.scm ------------------------------ (define fail (lambda () 999999)) @@ -181,7 +173,7 @@ (fail))) => 543) -; ==== test09-hygiene.scm ====================================================== +; ---- chibi-scheme/tests/basic/test09-hygiene.scm ----------------------------- (check (or 1) => 1) @@ -215,7 +207,8 @@ (cons (rename 'myor) (cddr expr)))))))) (check (let ((tmp 6)) - (myor #f tmp)) => 6) + (myor #f tmp)) + => 6) (check (let ((x 'outer)) (let-syntax ((with-x @@ -227,7 +220,7 @@ (with-x z (z))))) => 'outer) -; ==== test10-unhygiene.scm ==================================================== +; ---- chibi-scheme/tests/basic/test10-unhygiene.scm --------------------------- ; (define-syntax aif ; (sc-macro-transformer diff --git a/test/circular-list.ss b/test/circular-list.ss index 8defd303d..435ad3196 100644 --- a/test/circular-list.ss +++ b/test/circular-list.ss @@ -5,11 +5,8 @@ (srfi 78)) (define (print . xs) - (for-each (lambda (x) - (display x)) - xs) - (newline) - ) + (for-each display xs) + (newline)) (let ((x (list 'a 'b 'c))) (set-cdr! (cddr x) x) diff --git a/test/environment.cpp b/test/environment.cpp index 0a19d79e3..4fbe8bf57 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -25,15 +25,17 @@ auto main() -> int assert(gc_count == specials_count); - library::boot(); + boot(); - symbols.clear(); + symbols().clear(); - assert(symbols.empty()); + assert(symbols().empty()); const_cast(interaction_environment()).reset(); // DIRTY HACK! - libraries.clear(); + libraries().clear(); + + assert(libraries().empty()); gc.collect(); gc.collect(); // for vector type diff --git a/test/identifier.ss b/test/identifier.ss index 74615c902..0a1bb8a3f 100644 --- a/test/identifier.ss +++ b/test/identifier.ss @@ -1,8 +1,8 @@ (import (only (meevax macro) syntactic-closure?) + (meevax macro-transformer) (scheme base) (scheme process-context) - (srfi 78) - (srfi 211 explicit-renaming)) + (srfi 78)) (define value 42) diff --git a/test/internal-definition.ss b/test/internal-definition.ss index 9a42f70d6..374416400 100644 --- a/test/internal-definition.ss +++ b/test/internal-definition.ss @@ -1,7 +1,7 @@ -(import (scheme base) +(import (meevax macro-transformer) + (scheme base) (scheme cxr) (scheme process-context) - (srfi 211 explicit-renaming) (srfi 78)) (define a 100) diff --git a/test/macro-transformers.ss b/test/macro-transformers.ss index 612c6bec9..00f121d69 100644 --- a/test/macro-transformers.ss +++ b/test/macro-transformers.ss @@ -1,15 +1,12 @@ -(import (scheme base) +(import (meevax macro-transformer) + (scheme base) (scheme cxr) (scheme process-context) (scheme write) - (srfi 78) - (only (srfi 211 syntactic-closures) make-syntactic-closure rsc-macro-transformer sc-macro-transformer) - (only (srfi 211 explicit-renaming) er-macro-transformer)) + (srfi 78)) (define (print . xs) - (for-each (lambda (x) - (display x)) - xs) + (for-each display xs) (newline)) ; ---- DEFINE-SYNTAX ----------------------------------------------------------- diff --git a/test/r4rs-appendix.ss b/test/r4rs-appendix.ss index 16c5a7105..a2a813b10 100644 --- a/test/r4rs-appendix.ss +++ b/test/r4rs-appendix.ss @@ -1,8 +1,7 @@ -(import (scheme base) +(import (meevax macro-transformer) + (scheme base) (scheme process-context) - (srfi 78) - (except (srfi 211 syntactic-closures) identifier?) - (srfi 211 explicit-renaming)) + (srfi 78)) ; (check (symbol? (syntax x)) => #f) diff --git a/test/r7rs.ss b/test/r7rs.ss index 6750185e9..28117b1c9 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -1381,37 +1381,37 @@ ; ---- 6.9. -------------------------------------------------------------------- -; (check (bytevector? #u8(0 10 5)) => #t) +(check (bytevector? #u8(0 10 5)) => #t) -; (check (make-bytevector 2 12) => #u8(12 12)) +(check (make-bytevector 2 12) => #u8(12 12)) -; (check (bytevector 1 3 5 1 3 5) => #u8(1 3 5 1 3 5)) +(check (bytevector 1 3 5 1 3 5) => #u8(1 3 5 1 3 5)) -; (check (bytevector) => #u8()) +(check (bytevector) => #u8()) -; (check (bytevector-u8-ref '#u8(1 1 2 3 5 8 13 21) 5) => 8) +(check (bytevector-u8-ref '#u8(1 1 2 3 5 8 13 21) 5) => 8) -; (check (let ((bv (bytevector 1 2 3 4))) -; (bytevector-u8-set! bv 1 3) -; bv) => #u8(1 3 3 4)) +(check (let ((bv (bytevector 1 2 3 4))) + (bytevector-u8-set! bv 1 3) + bv) => #u8(1 3 3 4)) -; (define a #u8(1 2 3 4 5)) +(define a #u8(1 2 3 4 5)) -; (check (bytevector-copy a 2 4) => #u8(3 4)) +(check (bytevector-copy a 2 4) => #u8(3 4)) -; (define a (bytevector 1 2 3 4 5)) +(define a (bytevector 1 2 3 4 5)) -; (define b (bytevector 10 20 30 40 50)) +(define b (bytevector 10 20 30 40 50)) -; (bytevector-copy! b 1 a 0 2) +(bytevector-copy! b 1 a 0 2) -; (check b => #u8(10 1 2 40 50)) +(check b => #u8(10 1 2 40 50)) -; (check (bytevector-append #u8(0 1 2) #u8(3 4 5)) => #u8(0 1 2 3 4 5)) +(check (bytevector-append #u8(0 1 2) #u8(3 4 5)) => #u8(0 1 2 3 4 5)) -; (check (utf8->string #u8(#x41)) => "A") +(check (utf8->string #u8(#x41)) => "A") -; (check (string->utf8 "λ") => #u8(#xCE #xBB)) +(check (string->utf8 "λ") => #u8(#xCE #xBB)) ; ---- 6.10. ------------------------------------------------------------------- @@ -1454,26 +1454,29 @@ "HAL") => "IBM") -; (check (string-map (lambda (c k) -; ((if (eqv? k #\u) char-upcase char-downcase) -; c)) -; "studlycaps xxx" -; "ululululul") => "StUdLyCaPs") +(check (string-map (lambda (c k) + ((if (eqv? k #\u) char-upcase char-downcase) + c)) + "studlycaps xxx" + "ululululul") + => "StUdLyCaPs") -; (check (vector-map cadr '#((a b) (d e) (g h))) => #(b e h)) +(check (vector-map cadr '#((a b) (d e) (g h))) => #(b e h)) -; (check (vector-map (lambda (n) -; (expt n n)) -; '#(1 2 3 4 5)) => (1 4 27 256 3125)) +(check (vector-map (lambda (n) + (expt n n)) + '#(1 2 3 4 5)) + => #(1 4 27 256 3125)) -; (check (vector-map + '#(1 2 3) '#(4 5 6 7)) => #(5 7 9)) +(check (vector-map + '#(1 2 3) '#(4 5 6 7)) => #(5 7 9)) -; (check (let ((count 0)) -; (vector-map -; (lambda (ignored) -; (set! count (+ count 1)) -; count) -; '#(a b))) => #(1 2)) ; or #(2 1) +(check (let ((count 0)) + (vector-map + (lambda (ignored) + (set! count (+ count 1)) + count) + '#(a b))) + => #(1 2)) ; or #(2 1) (check (let ((v (make-vector 5))) (for-each (lambda (i) @@ -1600,4 +1603,4 @@ (check-report) -(exit (check-passed? 404)) +(exit (check-passed? 420)) diff --git a/test/srfi-31.ss b/test/srfi-31.ss new file mode 100644 index 000000000..2820ccafc --- /dev/null +++ b/test/srfi-31.ss @@ -0,0 +1,19 @@ +(import (scheme base) + (scheme process-context) + (srfi 31) + (srfi 78)) + +(define F (rec (F N) + ((rec (G K L) + (if (zero? K) L + (G (- K 1) (* K L)))) N 1))) + +(check (procedure? F) => #t) + +(check (F 0) => 1) + +(check (F 10) => 3628800) + +(check-report) + +(exit (check-passed? 3)) diff --git a/test/vector.cpp b/test/vector.cpp index 28a090444..ae2918c9e 100644 --- a/test/vector.cpp +++ b/test/vector.cpp @@ -128,7 +128,8 @@ auto main() -> int assert(v.as().objects.size() == 0); } - symbols.clear(); + symbols().clear(); + gc.collect(); // vector literal @@ -167,8 +168,9 @@ auto main() -> int assert(gc.count() == gc_count + 4); } - symbols.clear(); - gc.count(); + symbols().clear(); + + gc.collect(); // vector constructor {