diff --git a/CMakeLists.txt b/CMakeLists.txt index f59e8223f..6008cbafa 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -5,10 +5,11 @@ execute_process( COMMAND tr -d "\n" OUTPUT_VARIABLE CURRENT_VERSION) -project(meevax DESCRIPTION "A programmable programming language" - HOMEPAGE_URL "https://github.com/yamacir-kit/meevax" - LANGUAGES CXX - VERSION ${CURRENT_VERSION}) +project(meevax + DESCRIPTION "A programmable programming language" + HOMEPAGE_URL "https://github.com/yamacir-kit/meevax" + LANGUAGES CXX + VERSION ${CURRENT_VERSION}) include(GNUInstallDirs) @@ -20,9 +21,9 @@ string(JOIN " " AGGRESSIVE_OPTIMIZATION_OPTIONS ) set(CMAKE_CXX_EXTENSIONS OFF) -set(CMAKE_CXX_FLAGS_DEBUG "-Og -gdwarf-4") # NOTE: The `-gdwarf-4` option is set due to the following issues with Clang 14 and Valgrind versions below 3.20: https://bugzilla.mozilla.org/show_bug.cgi?id=1758782 -set(CMAKE_CXX_FLAGS_MINSIZEREL "-Os -DNDEBUG") -set(CMAKE_CXX_FLAGS_RELEASE "-O2 -DNDEBUG ${AGGRESSIVE_OPTIMIZATION_OPTIONS}") +set(CMAKE_CXX_FLAGS_DEBUG "-Og -gdwarf-4") # NOTE: The `-gdwarf-4` option is set due to the following issues with Clang 14 and Valgrind versions below 3.20: https://bugzilla.mozilla.org/show_bug.cgi?id=1758782 +set(CMAKE_CXX_FLAGS_MINSIZEREL "-Os -DNDEBUG") +set(CMAKE_CXX_FLAGS_RELEASE "-O2 -DNDEBUG ${AGGRESSIVE_OPTIMIZATION_OPTIONS}") set(CMAKE_CXX_FLAGS_RELWITHDEBINFO "-O2 -gdwarf-4 -DNDEBUG") set(CMAKE_CXX_FLAGS "-Wall -Wextra -Wpedantic -pipe") set(CMAKE_CXX_STANDARD 17) @@ -67,36 +68,27 @@ configure_file(${CMAKE_CURRENT_SOURCE_DIR}/configure/version.cpp ${CMAKE_CURRENT add_library(kernel SHARED) -add_library(${PROJECT_NAME}::kernel ALIAS kernel) - file(GLOB_RECURSE ${PROJECT_NAME}_KERNEL_SOURCES ${CMAKE_CURRENT_SOURCE_DIR}/src/*/*.cpp) target_sources(kernel PRIVATE ${${PROJECT_NAME}_KERNEL_SOURCES}) -target_include_directories(kernel PUBLIC - $ - $) - -target_link_libraries(kernel PRIVATE ${CMAKE_DL_LIBS} - PUBLIC gmp) - -set_target_properties(kernel PROPERTIES OUTPUT_NAME ${PROJECT_NAME} # Rename libkernel => libmeevax - VERSION ${PROJECT_VERSION} - SOVERSION ${PROJECT_VERSION_MAJOR} - LINK_FLAGS_RELEASE -s) - -# ---- Target format ----------------------------------------------------------- - -add_executable(format) +target_include_directories(kernel + PUBLIC $ + PUBLIC $) -target_sources(format PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/src/format.cpp) +target_link_libraries(kernel + PRIVATE ${CMAKE_DL_LIBS} + PUBLIC gmp) -target_link_libraries(format PRIVATE kernel) +set_target_properties(kernel PROPERTIES + OUTPUT_NAME ${PROJECT_NAME} # Rename libkernel => libmeevax + VERSION ${PROJECT_VERSION} + SOVERSION ${PROJECT_VERSION_MAJOR} + LINK_FLAGS_RELEASE -s) # ---- Target basis ------------------------------------------------------------ add_custom_target(basis - DEPENDS format COMMAND ${CMAKE_COMMAND} -P ${CMAKE_CURRENT_SOURCE_DIR}/configure/basis.cmake) # ---- Target shell ------------------------------------------------------------ @@ -109,8 +101,9 @@ target_sources(shell PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/src/main.cpp) target_link_libraries(shell PRIVATE kernel) -set_target_properties(shell PROPERTIES OUTPUT_NAME ${PROJECT_NAME} # Rename shell => meevax - LINK_FLAGS_RELEASE -s) +set_target_properties(shell PROPERTIES + OUTPUT_NAME ${PROJECT_NAME} # Rename shell => meevax + LINK_FLAGS_RELEASE -s) # ---- CMake Package ----------------------------------------------------------- @@ -122,29 +115,30 @@ write_basic_package_version_file( # ---- Target install ---------------------------------------------------------- -# /usr/lib/libmeevax -install(TARGETS kernel - EXPORT ${PROJECT_NAME}-config - ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} - LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) +install( # /usr/lib/libmeevax + TARGETS kernel + EXPORT ${PROJECT_NAME}-config + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) -# /usr/bin/meevax -install(TARGETS shell - RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) +install( # /usr/bin/meevax + TARGETS shell + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) -# /usr/include/meevax -install(DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/include/ - DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) +install( # /usr/include/meevax + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/include/ + DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) -# /usr/share/meevax/meevax-config.cmake -install(EXPORT ${PROJECT_NAME}-config - EXPORT_LINK_INTERFACE_LIBRARIES - DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME} - NAMESPACE Meevax::) +install( # /usr/share/meevax/meevax-config.cmake + EXPORT ${PROJECT_NAME}-config + EXPORT_LINK_INTERFACE_LIBRARIES + DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME} + NAMESPACE Meevax::) # /usr/share/meevax/meevax-config-version.cmake -install(FILES ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake - DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}) +install( + FILES ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake + DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}) # ---- Target package ---------------------------------------------------------- @@ -164,20 +158,22 @@ 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) +set(${PROJECT_NAME}_MEMORY_CHECK_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 ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND} - ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND_OPTIONS} - ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/meevax - ${EACH}) + add_test( + NAME ${FILENAME} + COMMAND ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND} + ${${PROJECT_NAME}_MEMORY_CHECK_OPTIONS} + ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/meevax + ${EACH}) endforeach() file(GLOB ${PROJECT_NAME}_TEST_CPP ${CMAKE_CURRENT_SOURCE_DIR}/test/*.cpp) @@ -187,10 +183,11 @@ foreach(EACH IN LISTS ${PROJECT_NAME}_TEST_CPP) add_executable(assert-${FILENAME} ${EACH}) add_dependencies(assert-${FILENAME} basis) target_link_libraries(assert-${FILENAME} PRIVATE kernel) - add_test(NAME assert-${FILENAME} - COMMAND ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND} - ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND_OPTIONS} - ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/assert-${FILENAME}) + add_test( + NAME assert-${FILENAME} + COMMAND ${${PROJECT_NAME}_MEMORY_CHECK_COMMAND} + ${${PROJECT_NAME}_MEMORY_CHECK_OPTIONS} + ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/assert-${FILENAME}) endforeach() # ---- Additional Targets ------------------------------------------------------ diff --git a/README.md b/README.md index 9fab71bc0..dcf19d464 100644 --- a/README.md +++ b/README.md @@ -46,34 +46,34 @@ Procedures for each standard are provided by the following R7RS-style libraries: |:--------:|--------------| | R4RS | [`(scheme r4rs)`](./basis/r4rs.ss) | R5RS | [`(scheme r5rs)`](./basis/r5rs.ss) -| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) +| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme list)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) ### SRFIs -| Number | Title | Library name | Note | -|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|-----------------------------------| -| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | -| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | -| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | -| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | -| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | -| [ 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 | -| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | -| [ 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 | -| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | -| [ 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 | -| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | -| [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 | +| Number | Title | Library name | Note | +|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|------------------------------------| +| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | +| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | [`(scheme list)`](./basis/r7rs.ss) | +| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | +| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | +| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | +| [ 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 | +| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | +| [ 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 | +| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | +| [ 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 | +| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | +| [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 | ## Installation @@ -91,7 +91,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.32_amd64.deb +sudo apt install build/meevax_0.5.63_amd64.deb ``` or @@ -123,9 +123,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.32.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.63.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.32_amd64.deb` +| `package` | Generate debian package `meevax_0.5.63_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 32a910026..08c80f334 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.32 +0.5.63 diff --git a/]end( b/]end( new file mode 100644 index 000000000..e69de29bb diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 1738f4a7e..22353c49b 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -2,7 +2,7 @@ (import (only (meevax core) include include-case-insensitive) (only (meevax error) error-object? read-error? file-error?) (only (meevax macro-transformer) er-macro-transformer) - (only (meevax list) make-list) + (only (meevax list) make-list list-copy) (only (meevax number) exact-integer? exact-integer-square-root) (only (meevax port) binary-port? eof-object flush get-output-u8vector open-input-u8vector open-output-u8vector open? port? standard-error-port standard-input-port standard-output-port textual-port?) (prefix (meevax read) %) @@ -191,13 +191,6 @@ (define (list-set! xs k x) (set-car! (list-tail xs k) x)) - (define (list-copy x) - (let list-copy ((x x)) - (if (pair? x) - (cons (car x) - (list-copy (cdr x))) - x))) - (define symbol=? eqv?) (define bytevector? u8vector?) @@ -472,6 +465,29 @@ (import (srfi 45)) (export delay (rename lazy delay-force) force promise? (rename eager make-promise))) +(define-library (scheme list) + (import (srfi 1)) + (export cons list xcons cons* make-list list-tabulate list-copy circular-list + iota pair? null? proper-list? circular-list? dotted-list? not-pair? + null-list? list= car 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 + list-ref first second third fourth fifth sixth seventh eighth ninth + tenth car+cdr take take! take-right drop drop-right drop-right! + split-at split-at! last last-pair length length+ append append! + concatenate concatenate! reverse reverse! append-reverse + append-reverse! zip unzip1 unzip2 unzip3 unzip4 unzip5 count map map! + filter-map map-in-order fold fold-right unfold unfold-right pair-fold + pair-fold-right reduce reduce-right append-map append-map! for-each + pair-for-each filter filter! partition partition! remove remove! memq + memv member find find-tail any every list-index take-while + take-while! drop-while span span! break break! delete delete! + delete-duplicates delete-duplicates! assq assv assoc alist-cons + alist-copy alist-delete alist-delete! lset<= lset= lset-adjoin + lset-union lset-union! lset-intersection lset-intersection! + lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection! set-car! set-cdr!)) + (define-library (scheme load) (import (only (scheme r5rs) load)) (export load)) diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index d5d71bc1a..c7e791bf9 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -7,923 +7,896 @@ |# (define-library (srfi 1) - (import (scheme base) - (scheme cxr) - (srfi 8)) - - (export cons list xcons cons* make-list list-tabulate list-copy circular-list - iota pair? null? proper-list? circular-list? dotted-list? not-pair? - null-list? list= car 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 - list-ref first second third fourth fifth sixth seventh eighth ninth - tenth car+cdr take drop take-right drop-right take! drop-right! - split-at split-at! last last-pair length length+ append concatenate - reverse append! concatenate! reverse! append-reverse append-reverse! - zip unzip1 unzip2 unzip3 unzip4 unzip5 count map for-each fold unfold - pair-fold reduce fold-right unfold-right pair-fold-right reduce-right - append-map append-map! map! pair-for-each filter-map map-in-order - filter partition remove filter! partition! remove! member memq memv - find find-tail any every list-index take-while drop-while take-while! - span break span! break! delete delete-duplicates delete! - delete-duplicates! assoc assq assv alist-cons alist-copy alist-delete - alist-delete! lset<= lset= lset-adjoin lset-union lset-union! - lset-intersection lset-intersection! lset-difference lset-difference! - lset-xor lset-xor! lset-diff+intersection lset-diff+intersection! + (import (only (meevax boolean) not) + (only (meevax core) begin call-with-current-continuation! define if lambda letrec quote set!) + (only (meevax list) + alist-cons alist-copy append append! append-reverse append-reverse! + assq assv circular-list circular-list? concatenate concatenate! + dotted-list? drop drop-right drop-right! eighth fifth first fourth + iota last last-pair length length+ list list? list-copy list-ref + make-list memq memv ninth null? null-list? reverse reverse! second + seventh sixth take take! take-right tenth third) + (only (meevax pair) + car 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 cons cons* + not-pair? pair? set-car! set-cdr! xcons) + (only (scheme r5rs) + cond and or let let* eqv? eq? equal? = < zero? + - member assoc + apply map for-each values) + (only (srfi 8) receive) + (only (srfi 23) error)) + + (export ; Constructors + cons list xcons cons* make-list list-tabulate list-copy circular-list + iota + + ; Predicates + pair? null? proper-list? circular-list? dotted-list? not-pair? + null-list? list= + + ; Selectors + car 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 + list-ref + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr + take take! take-right + drop drop-right drop-right! + split-at split-at! + last last-pair + + ; Miscellaneous: length, append, concatenate, reverse, zip & count + length length+ + append append! + concatenate concatenate! + reverse reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 + count + + ; Fold, unfold & map + map map! filter-map map-in-order + fold fold-right + unfold unfold-right + pair-fold pair-fold-right + reduce reduce-right + append-map append-map! + for-each pair-for-each + + ; Filtering & partitioning + filter filter! + partition partition! + remove remove! + + ; Searching + memq memv member + find find-tail + any every list-index + take-while take-while! + drop-while + span span! + break break! + + ; Deleting + delete delete! + delete-duplicates delete-duplicates! + + ; Association lists + assq assv assoc alist-cons alist-copy alist-delete alist-delete! + + ; Set operations on lists + lset<= lset= + lset-adjoin + lset-union lset-union! + lset-intersection lset-intersection! + lset-difference lset-difference! + lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection! + + ; Primitive side-effects set-car! set-cdr!) - (begin (define (xcons x y) - (cons y x)) - - (define (tree-copy x) - (letrec ((tree-copy (lambda (x) - (if (not (pair? x)) x - (cons (tree-copy (car x)) - (tree-copy (cdr x))))))) - (tree-copy x))) - - (define (list-tabulate len proc) - (do ((i (- len 1) (- i 1)) - (ans '() (cons (proc i) ans))) - ((< i 0) ans))) - - (define (cons* x . xs) - (let cons* ((x x) - (xs xs)) - (if (pair? xs) - (cons x (cons* (car xs) - (cdr xs))) - x))) - - (define (circular-list val1 . vals) - (let ((ans (cons val1 vals))) - (set-cdr! (last-pair ans) ans) - ans)) - - (define (iota count . maybe-start+step) - (if (< count 0) (error "Negative step count" iota count)) - (let-optionals maybe-start+step ((start 0) (step 1)) - (let loop ((n 0) (r '())) - (if (= n count) - (reverse r) - (loop (+ 1 n) - (cons (+ start (* n step)) r)))))) + (begin (define (list-tabulate k f) + (let recur ((i 0)) + (if (< i k) + (cons (f i) + (recur (+ i 1))) + '()))) (define proper-list? list?) - (define (dotted-list? x) - (let rec ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (rec x lag))) - (not (null? x)))) - (not (null? x))))) - - (define (circular-list? x) - (let rec ((x x) - (y x)) - (and (pair? x) - (let ((x (cdr x))) - (and (pair? x) - (let ((x (cdr x)) - (y (cdr y))) - (or (eq? x y) - (rec x y)))))))) - - (define (not-pair? x) (not (pair? x))) - - (define (null-list? x) - (cond ((pair? x) #f) - ((null? x) #t) - (else (error "argument out of domain" (list 'null-list? x))))) - - (define (list= = . lists) - (or (null? lists) ; special case - (let lp1 ((list-a (car lists)) - (others (cdr lists))) - (or (null? others) - (let ((list-b (car others)) - (others (cdr others))) - (if (eq? list-a list-b) ; EQ? => LIST= - (lp1 list-b others) - (let lp2 ((pair-a list-a) - (pair-b list-b)) - (if (null-list? pair-a) - (and (null-list? pair-b) - (lp1 list-b others)) - (and (not (null-list? pair-b)) - (= (car pair-a) - (car pair-b)) - (lp2 (cdr pair-a) - (cdr pair-b))))))))))) - - (define first car) - - (define second cadr) - - (define third caddr) - - (define fourth cadddr) - - (define (fifth x) - (car (cddddr x))) - - (define (sixth x) - (cadr (cddddr x))) - - (define (seventh x) - (caddr (cddddr x))) - - (define (eighth x) - (cadddr (cddddr x))) - - (define (ninth x) - (car (cddddr (cddddr x)))) - - (define (tenth x) - (cadr (cddddr (cddddr x)))) + (define (list= x=? . xss) + (or (null? xss) + (let outer ((xs (car xss)) + (xss (cdr xss))) + (or (null? xss) + (let ((ys (car xss)) + (xss (cdr xss))) + (if (eq? xs ys) + (outer ys xss) + (let inner ((a xs) + (b ys)) + (if (null-list? a) + (and (null-list? b) + (outer ys xss)) + (and (not (null-list? b)) + (x=? (car a) + (car b)) + (inner (cdr a) + (cdr b))))))))))) (define (car+cdr pair) (values (car pair) (cdr pair))) - (define (take x k) - (let rec ((x x) - (k k)) - (if (zero? k) '() - (cons (car x) - (rec (cdr x) (- k 1)))))) - - (define (take! x k) + (define (split-at xs k) (if (zero? k) - (begin (set-cdr! (drop x (- k 1)) '()) x))) - - (define (drop x k) - (let rec ((x x) (k k)) - (if (zero? k) x - (rec (cdr x) (- k 1))))) - - (define (drop! lis k) - (if (negative? k) - (let ((nelts (+ k (length lis)))) - (if (zero? nelts) '() - (begin (set-cdr! (list-tail lis (- nelts 1)) '()) - lis))) - (list-tail lis k))) - - (define (take-right x k) - (let lp ((lag x) - (lead (drop x k))) - (if (pair? lead) - (lp (cdr lag) - (cdr lead)) - lag))) - - (define (drop-right x k) - (let rec ((lag x) (lead (drop x k))) - (if (pair? lead) - (cons (car lag) - (rec (cdr lag) (cdr lead))) - '()))) - - (define (drop-right! x k) - (let ((lead (drop x k))) - (if (pair? lead) - (let rec ((lag x) - (lead (cdr lead))) - (if (pair? lead) - (rec (cdr lag) - (cdr lead)) - (begin (set-cdr! lag '()) x))) - '()))) - - (define (split-at x k) - (let recur ((lis x) (k k)) - (if (zero? k) (values '() lis) - (receive (prefix suffix) (recur (cdr lis) (- k 1)) - (values (cons (car lis) prefix) suffix))))) + (values '() xs) + (receive (a b) (split-at (cdr xs) + (- k 1)) + (values (cons (car xs) + a) + b)))) (define (split-at! x k) (if (zero? k) (values '() x) - (let* ((prev (drop x (- k 1))) - (suffix (cdr prev))) - (set-cdr! prev '()) + (let* ((prefix-last (drop x (- k 1))) + (suffix (cdr prefix-last))) + (set-cdr! prefix-last '()) (values x suffix)))) - (define (last x) (car (last-pair x))) - - (define (last-pair lis) - (let rec ((lis lis)) - (let ((tail (cdr lis))) - (if (pair? tail) (rec tail) lis)))) - - (define (length+ x) ; Returns #f if X is circular. - (let rec ((x x) (lag x) (len 0)) - (if (pair? x) - (let ((x (cdr x)) - (len (+ len 1))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag)) - (len (+ len 1))) - (and (not (eq? x lag)) (rec x lag len))) - len)) - len))) - - (define (append! . lists) - (let lp ((lists lists) (prev '())) ; First, scan through lists looking for a non-empty one. - (if (not (pair? lists)) prev - (let ((first (car lists)) - (rest (cdr lists))) - (if (not (pair? first)) (lp rest first) - (let lp2 ((tail-cons (last-pair first)) ; Now, do the splicing. - (rest rest)) - (if (pair? rest) - (let ((next (car rest)) - (rest (cdr rest))) - (set-cdr! tail-cons next) - (lp2 (if (pair? next) (last-pair next) tail-cons) - rest)) - first))))))) - - (define (concatenate xs) - (reduce-right append '() xs)) - - (define (concatenate! xs) - (reduce-right append! '() xs)) - - (define (reverse! lis) - (let lp ((lis lis) (ans '())) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (set-cdr! lis ans) - (lp tail lis))))) - - (define (append-reverse rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (lp (cdr rev-head) (cons (car rev-head) tail))))) - - (define (append-reverse! rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (let ((next-rev (cdr rev-head))) - (set-cdr! rev-head tail) - (lp next-rev rev-head))))) - - (define (zip list1 . more-lists) - (apply map list list1 more-lists)) - - (define (unzip1 lis) - (map car lis)) - - (define (unzip2 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle - (let ((elt (car lis))) ; dotted lists. - (receive (a b) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b))))))) - - (define (unzip3 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis) - (let ((elt (car lis))) - (receive (a b c) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c))))))) - - (define (unzip4 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d))))))) - - (define (unzip5 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d e) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d) - (cons (car (cddddr elt)) e))))))) - - (define (count pred list1 . lists) - (if (pair? lists) - (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1) i - (receive (as ds) (%cars+cdrs lists) - (if (null? as) i - (lp (cdr list1) ds - (if (apply pred (car list1) as) (+ i 1) i)))))) - (let lp ((lis list1) (i 0)) - (if (null-list? lis) i - (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) - - (define (fold kons knil lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans knil)) - (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) - (if (null? cars+ans) ans ; Done. - (lp cdrs (apply kons cars+ans))))) - (let lp ((lis lis1) (ans knil)) - (if (null-list? lis) ans - (lp (cdr lis) (kons (car lis) ans)))))) - - (define (unfold p f g seed . maybe-tail-gen) - (if (pair? maybe-tail-gen) - (let ((tail-gen (car maybe-tail-gen))) - (if (pair? (cdr maybe-tail-gen)) - (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) - (let recur ((seed seed)) - (if (p seed) (tail-gen seed) - (cons (f seed) (recur (g seed))))))) + (define (zip x . xs) + (apply map list x xs)) + + (define (unzip1 xs) + (map car xs)) + + (define (unzip2 xs) + (let unzip2 ((xs xs)) + (if (null-list? xs) + (values xs xs) + (let ((x (car xs))) + (receive (a b) (unzip2 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b))))))) + + (define (unzip3 xs) + (let unzip3 ((xs xs)) + (if (null-list? xs) + (values xs xs xs) + (let ((x (car xs))) + (receive (a b c) (unzip3 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b) + (cons (caddr x) c))))))) + + (define (unzip4 xs) + (let unzip4 ((xs xs)) + (if (null-list? xs) + (values xs xs xs xs) + (let ((x (car xs))) + (receive (a b c d) (unzip4 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b) + (cons (caddr x) c) + (cons (cadddr x) d))))))) + + (define (unzip5 xs) + (let unzip5 ((xs xs)) + (if (null-list? xs) + (values xs xs xs xs xs) + (let ((x (car xs))) + (receive (a b c d e) (unzip5 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b) + (cons (caddr x) c) + (cons (cadddr x) d) + (cons (car (cddddr x)) e))))))) + + (define (count satisfy? x . xs) + (if (pair? xs) + (let recur ((x x) + (xs xs) + (i 0)) + (if (null-list? x) + i + (receive (as ds) (%cars+cdrs xs) + (if (null? as) i + (recur (cdr x) + ds + (if (apply satisfy? (car x) as) + (+ i 1) + i)))))) + (let recur ((x x) + (i 0)) + (if (null-list? x) + i + (recur (cdr x) + (if (satisfy? (car x)) + (+ i 1) + i)))))) + + (define (fold f z x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs)) + (ans z)) + (receive (cars+ans cdrs) (%cars+cdrs+ xs ans) + (if (null? cars+ans) + ans + (recur cdrs (apply f cars+ans))))) + (let recur ((x x) + (ans z)) + (if (null-list? x) + ans + (recur (cdr x) + (f (car x) ans)))))) + + (define (unfold p f g seed . generate) + (if (pair? generate) + (let ((generate (car generate))) + (let recur ((seed seed)) + (if (p seed) + (generate seed) + (cons (f seed) + (recur (g seed)))))) (let recur ((seed seed)) - (if (p seed) '() - (cons (f seed) (recur (g seed))))))) - - (define (pair-fold f zero lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans zero)) - (let ((tails (%cdrs lists))) - (if (null? tails) ans - (lp tails (apply f (append! lists (list ans))))))) - - (let lp ((lis lis1) (ans zero)) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (lp tail (f lis ans))))))) - - (define (reduce f ridentity lis) - (if (null-list? lis) ridentity - (fold f (car lis) (cdr lis)))) - - (define (fold-right f knil x . xs) + (if (p seed) + '() + (cons (f seed) + (recur (g seed))))))) + + (define (pair-fold f z x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs)) + (ans z)) + (let ((tails (%cdrs xs))) + (if (null? tails) + ans + (recur tails (apply f (append! xs (list ans))))))) + (let recur ((x x) + (ans z)) + (if (null-list? x) + ans + (let ((tail (cdr x))) + (recur tail (f x ans))))))) + + (define (reduce f ridentity x) + (if (null-list? x) + ridentity + (fold f (car x) (cdr x)))) + + (define (fold-right f z x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (let ((cdrs (%cdrs xs))) + (if (null? cdrs) + z + (apply f (%cars+ xs (recur cdrs)))))) + (let recur ((xs x)) + (if (null-list? xs) + z + (let ((x (car xs))) + (f x (recur (cdr xs)))))))) + + (define (unfold-right p f g seed . tail) + (let recur ((seed seed) + (ans (if (pair? tail) + (car tail) + '()))) + (if (p seed) + ans + (recur (g seed) + (cons (f seed) ans))))) + + (define (pair-fold-right f z x . xs) (if (pair? xs) - (letrec ((recur (lambda (lists) - ((lambda (cdrs) - (if (null? cdrs) knil - (apply f (%cars+ lists (recur cdrs))))) - (%cdrs lists))))) - (recur (cons x xs))) - (letrec ((recur (lambda (x) - (if (null-list? x) knil - ((lambda (head) - (f head (recur (cdr x)))) - (car x)))))) - (recur x)))) - - (define (unfold-right p f g seed . maybe-tail) - (let lp ((seed seed) - (ans (if (pair? maybe-tail) (car maybe-tail) '()))) - (if (p seed) ans - (lp (g seed) - (cons (f seed) ans))))) - - (define (pair-fold-right f zero lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) zero - (apply f (append! lists (list (recur cdrs))))))) - (let recur ((lis lis1)) - (if (null-list? lis) zero (f lis (recur (cdr lis))))))) - - (define (reduce-right f ridentity lis) - (if (null-list? lis) ridentity - (let recur ((head (car lis)) (lis (cdr lis))) - (if (pair? lis) - (f head (recur (car lis) (cdr lis))) - head)))) - - (define (append-map f lis1 . lists) - (really-append-map append-map append f lis1 lists)) - - (define (append-map! f lis1 . lists) - (really-append-map append-map! append! f lis1 lists)) - - (define (really-append-map who appender f lis0 lists) - (if (pair? lists) - (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) - (if (null? cars) '() - (let recur ((cars cars) (cdrs cdrs)) - (let ((vals (apply f cars))) - (receive (cars2 cdrs2) (%cars+cdrs cdrs) - (if (null? cars2) vals - (appender vals (recur cars2 cdrs2)))))))) - (if (null-list? lis1) '() - (let recur ((elt (car lis1)) (rest (cdr lis1))) - (let ((vals (f elt))) - (if (null-list? rest) vals - (appender vals (recur (car rest) (cdr rest))))))))) - - (define (map! f lis1 . lists) - (if (pair? lists) - (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1)) - (receive (heads tails) (%cars+cdrs/no-test lists) - (set-car! lis1 (apply f (car lis1) heads)) - (lp (cdr lis1) tails)))) - (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) - lis1) - - (define (pair-for-each proc lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists))) - (let ((tails (%cdrs lists))) + (let recur ((xs (cons x xs))) + (let ((cdrs (%cdrs xs))) + (if (null? cdrs) + z + (apply f (append! xs (list (recur cdrs))))))) + (let recur ((x x)) + (if (null-list? x) + z + (f x (recur (cdr x))))))) + + (define (reduce-right f ridentity xs) + (if (null-list? xs) + ridentity + (let reduce-right ((x (car xs)) + (xs (cdr xs))) + (if (pair? xs) + (f x (reduce-right (car xs) + (cdr xs))) + x)))) + + (define (append-map f x . xs) + (%append-map append-map append f x xs)) + + (define (append-map! f x . xs) + (%append-map append-map! append! f x xs)) + + (define (%append-map who appender f x xs) + (if (pair? xs) + (receive (cars cdrs) (%cars+cdrs (cons x xs)) + (if (null? cars) + '() + (let recur ((cars cars) + (cdrs cdrs)) + (let ((vals (apply f cars))) + (receive (cars2 cdrs2) (%cars+cdrs cdrs) + (if (null? cars2) + vals + (appender vals (recur cars2 cdrs2)))))))) + (if (null-list? x) + '() + (let recur ((x (car x)) + (xs (cdr x))) + (let ((vals (f x))) + (if (null-list? xs) + vals + (appender vals + (recur (car xs) + (cdr xs))))))))) + + (define (map! f x . xs) + (if (pair? xs) + (let recur ((x x) + (xs xs)) + (if (not (null-list? x)) + (receive (heads tails) (%cars+cdrs/no-test xs) + (set-car! x (apply f (car x) heads)) + (recur (cdr x) + tails)))) + (pair-for-each (lambda (pair) + (set-car! pair (f (car pair)))) + x)) + x) + + (define (pair-for-each f x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (let ((tails (%cdrs xs))) (if (pair? tails) - (begin (apply proc lists) - (lp tails))))) - (let lp ((lis lis1)) - (if (not (null-list? lis)) - (let ((tail (cdr lis))) - (proc lis) - (lp tail)))))) - - (define (filter-map f lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) - (else (recur cdrs))) ; Tail call in this arm. - '()))) - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (recur (cdr lis)))) - (cond ((f (car lis)) => (lambda (x) (cons x tail))) + (begin (apply f xs) + (recur tails))))) + (let recur ((x x)) + (if (not (null-list? x)) + (let ((tail (cdr x))) + (f x) + (recur tail)))))) + + (define (filter-map f x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (receive (cars cdrs) (%cars+cdrs xs) + (if (pair? cars) + (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) + (else (recur cdrs))) + '()))) + (let recur ((x x)) + (if (null-list? x) x + (let ((tail (recur (cdr x)))) + (cond ((f (car x)) => (lambda (x) (cons x tail))) (else tail))))))) - (define (map-in-order f lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (let ((x (apply f cars))) - (cons x (recur cdrs))) - '()))) - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (cdr lis)) - (x (f (car lis)))) + (define (map-in-order f x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (receive (cars cdrs) (%cars+cdrs xs) + (if (pair? cars) + (let ((x (apply f cars))) + (cons x (recur cdrs))) + '()))) + (let recur ((x x)) + (if (null-list? x) x + (let ((tail (cdr x)) + (x (f (car x)))) (cons x (recur tail))))))) - (define (filter pred lis) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) + (define (filter satisfy? x) + (let recur ((x x)) + (if (null-list? x) + x + (let ((head (car x)) + (tail (cdr x))) + (if (satisfy? head) (let ((new-tail (recur tail))) - (if (eq? tail new-tail) lis + (if (eq? tail new-tail) + x (cons head new-tail))) (recur tail)))))) - ; (define (filter pred lis) ; Another version that shares longest tail. - ; (receive (ans no-del?) - ; (let recur ((l l)) - ; (if (null-list? l) (values l #t) - ; (let ((x (car l)) - ; (tl (cdr l))) - ; (if (pred x) - ; (receive (ans no-del?) (recur tl) - ; (if no-del? - ; (values l #t) - ; (values (cons x ans) #f))) - ; (receive (ans no-del?) (recur tl) ; Delete X. - ; (values ans #f)))))) - ; ans)) - - (define (partition pred lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. - (let ((elt (car lis)) - (tail (cdr lis))) - (receive (in out) (recur tail) - (if (pred elt) - (values (if (pair? out) (cons elt in) lis) out) - (values in (if (pair? in) (cons elt out) lis)))))))) - - (define (remove satisfy? x) - (filter (lambda (y) (not (satisfy? y))) x)) - - ; Things are much simpler if you are willing to push N stack frames & do N - ; set-cdr! writes, where N is the length of the answer. - (define (filter! pred lis) - (let recur ((lis lis)) - (if (pair? lis) - (cond ((pred (car lis)) - (set-cdr! lis (recur (cdr lis))) - lis) - (else (recur (cdr lis)))) - lis))) - - ; (define (filter! pred lis) - ; (let lp ((ans lis)) - ; (cond ((null-list? ans) ans) - ; ((not (pred (car ans))) (lp (cdr ans))) - ; (else (letrec ((scan-in (lambda (prev lis) - ; (if (pair? lis) - ; (if (pred (car lis)) - ; (scan-in lis (cdr lis)) - ; (scan-out prev (cdr lis)))))) - ; (scan-out (lambda (prev lis) - ; (let lp ((lis lis)) - ; (if (pair? lis) - ; (if (pred (car lis)) - ; (begin (set-cdr! prev lis) - ; (scan-in lis (cdr lis))) - ; (lp (cdr lis))) - ; (set-cdr! prev lis)))))) - ; (scan-in ans (cdr ans)) - ; ans))))) - - (define (partition! pred lis) - (if (null-list? lis) - (values lis lis) - (letrec ((scan-in (lambda (in-prev out-prev lis) - (let lp ((in-prev in-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (lp lis (cdr lis)) - (begin (set-cdr! out-prev lis) - (scan-out in-prev lis (cdr lis)))) - (set-cdr! out-prev lis))))) - (scan-out (lambda (in-prev out-prev lis) - (let lp ((out-prev out-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! in-prev lis) - (scan-in lis out-prev (cdr lis))) - (lp lis (cdr lis))) - (set-cdr! in-prev lis)))))) - (if (pred (car lis)) - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values lis l)) - ((pred (car l)) (lp l (cdr l))) + (define (filter! satisfy? xs) + (let recur ((xs xs)) + (if (pair? xs) + (cond ((satisfy? (car xs)) + (set-cdr! xs (recur (cdr xs))) + xs) + (else (recur (cdr xs)))) + xs))) + + (define (partition satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + (values xs xs) + (let ((x (car xs))) + (receive (a b) (recur (cdr xs)) + (if (satisfy? x) + (values (if (pair? b) + (cons x a) + xs) + b) + (values a + (if (pair? a) + (cons x b) + xs)))))))) + + (define (partition! satisfy? xs) + (if (null-list? xs) + (values xs xs) + (letrec ((scan-in (lambda (in-prev out-prev xs) + (let recur ((in-prev in-prev) + (xs xs)) + (if (pair? xs) + (if (satisfy? (car xs)) + (recur xs (cdr xs)) + (begin (set-cdr! out-prev xs) + (scan-out in-prev xs (cdr xs)))) + (set-cdr! out-prev xs))))) + (scan-out (lambda (in-prev out-prev xs) + (let recur ((out-prev out-prev) + (xs xs)) + (if (pair? xs) + (if (satisfy? (car xs)) + (begin (set-cdr! in-prev xs) + (scan-in xs out-prev (cdr xs))) + (recur xs (cdr xs))) + (set-cdr! in-prev xs)))))) + (if (satisfy? (car xs)) + (let recur ((prev-l xs) + (l (cdr xs))) + (cond ((not (pair? l)) + (values xs l)) + ((satisfy? (car l)) + (recur l (cdr l))) (else (scan-out prev-l l (cdr l)) - (values lis l)))) - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values l lis)) - ((pred (car l)) + (values xs l)))) + (let recur ((prev-l xs) + (l (cdr xs))) + (cond ((not (pair? l)) + (values l xs)) + ((satisfy? (car l)) (scan-in l prev-l (cdr l)) - (values l lis)) - (else (lp l (cdr l))))))))) + (values l xs)) + (else (recur l (cdr l))))))))) - (define (remove! satisfy? x) - (filter! (lambda (y) (not (satisfy? y))) x)) + (define (remove satisfy? xs) + (filter (lambda (x) + (not (satisfy? x))) + xs)) - (define (find pred list) - (cond ((find-tail pred list) => car) + (define (remove! satisfy? xs) + (filter! (lambda (x) + (not (satisfy? x))) + xs)) + + (define (find satisfy? xs) + (cond ((find-tail satisfy? xs) => car) (else #f))) - (define (find-tail pred list) - (let lp ((list list)) - (and (not (null-list? list)) - (if (pred (car list)) list - (lp (cdr list)))))) - - (define (any pred lis1 . lists) - (if (pair? lists) - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (and (pair? heads) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (or (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) - (and (not (null-list? lis1)) - (let lp ((head (car lis1)) (tail (cdr lis1))) + (define (find-tail satisfy? xs) + (let recur ((xs xs)) + (and (not (null-list? xs)) + (if (satisfy? (car xs)) + xs + (recur (cdr xs)))))) + + (define (any satisfy? x . xs) + (if (pair? xs) + (receive (cars cdrs) (%cars+cdrs (cons x xs)) + (and (pair? cars) + (let recur ((cars cars) + (cdrs cdrs)) + (receive (next-cars next-cdrs) (%cars+cdrs cdrs) + (if (pair? next-cars) + (or (apply satisfy? cars) + (recur next-cars + next-cdrs)) + (apply satisfy? cars)))))) + (and (not (null-list? x)) + (let recur ((head (car x)) + (tail (cdr x))) (if (null-list? tail) - (pred head) - (or (pred head) (lp (car tail) (cdr tail)))))))) - - (define (every pred lis1 . lists) - (if (pair? lists) - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (or (not (pair? heads)) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (and (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) - (or (null-list? lis1) - (let lp ((head (car lis1)) (tail (cdr lis1))) + (satisfy? head) + (or (satisfy? head) + (recur (car tail) + (cdr tail)))))))) + + (define (every satisfy? x . xs) + (if (pair? xs) + (receive (heads tails) (%cars+cdrs (cons x xs)) + (or (not (pair? heads)) + (let recur ((heads heads) + (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (and (apply satisfy? heads) + (recur next-heads next-tails)) + (apply satisfy? heads)))))) + (or (null-list? x) + (let recur ((head (car x)) + (tail (cdr x))) (if (null-list? tail) - (pred head) - (and (pred head) (lp (car tail) (cdr tail)))))))) - - (define (list-index pred lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (n 0)) - (receive (heads tails) (%cars+cdrs lists) - (and (pair? heads) - (if (apply pred heads) n - (lp tails (+ n 1)))))) - (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis)) - (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - - (define (take-while pred lis) - (let recur ((lis lis)) - (if (null-list? lis) '() - (let ((x (car lis))) - (if (pred x) - (cons x (recur (cdr lis))) - '()))))) + (satisfy? head) + (and (satisfy? head) + (recur (car tail) + (cdr tail)))))))) - (define (drop-while pred lis) - (let lp ((lis lis)) - (if (null-list? lis) '() - (if (pred (car lis)) - (lp (cdr lis)) - lis)))) + (define (list-index satisfy? x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs)) + (n 0)) + (receive (heads tails) (%cars+cdrs xs) + (and (pair? heads) + (if (apply satisfy? heads) + n + (recur tails (+ n 1)))))) + (let recur ((xs x) + (n 0)) + (and (not (null-list? xs)) + (if (satisfy? (car xs)) + n + (recur (cdr xs) + (+ n 1))))))) + + (define (take-while satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + '() + (let ((x (car xs))) + (if (satisfy? x) + (cons x (recur (cdr xs))) + '()))))) - (define (take-while! pred lis) - (if (or (null-list? lis) (not (pred (car lis)))) '() - (begin (let lp ((prev lis) (rest (cdr lis))) + (define (take-while! satisfy? xs) + (if (or (null-list? xs) + (not (satisfy? (car xs)))) + '() + (begin (let recur ((prev xs) + (rest (cdr xs))) (if (pair? rest) (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) + (if (satisfy? x) + (recur rest (cdr rest)) (set-cdr! prev '()))))) - lis))) - - (define (span pred lis) - (let recur ((lis lis)) - (if (null-list? lis) (values '() '()) - (let ((x (car lis))) - (if (pred x) - (receive (prefix suffix) (recur (cdr lis)) - (values (cons x prefix) suffix)) - (values '() lis)))))) - - (define (break break? x) - (span (lambda (x) (not (break? x))) x)) - - (define (span! pred lis) - (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) - (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest) rest + xs))) + + (define (drop-while satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + '() + (if (satisfy? (car xs)) + (recur (cdr xs)) + xs)))) + + (define (span satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + (values '() '()) + (let ((x (car xs))) + (if (satisfy? x) + (receive (a b) (recur (cdr xs)) + (values (cons x a) b)) + (values '() xs)))))) + + (define (span! satisfy? xs) + (if (or (null-list? xs) + (not (satisfy? (car xs)))) + (values '() xs) + (let ((suffix (let recur ((prev xs) + (rest (cdr xs))) + (if (null-list? rest) + rest (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) + (if (satisfy? x) + (recur rest (cdr rest)) (begin (set-cdr! prev '()) rest))))))) - (values lis suffix)))) + (values xs suffix)))) + + (define (break break? x) + (span (lambda (x) + (not (break? x))) + x)) (define (break! break? x) - (span! (lambda (x) (not (break? x))) x)) - - (define (delete x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (y) (not (= x y))) lis))) - - (define (delete-duplicates lis . maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - - (define (delete! x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (y) (not (= x y))) lis))) - - (define (delete-duplicates! lis maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete! x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - - (define (alist-cons key datum alist) - (cons (cons key datum) alist)) - - (define (alist-copy alist) - (map (lambda (each) - (cons (car each) - (cdr each))) - alist)) - - (define (alist-delete key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (elt) (not (= key (car elt)))) alist))) - - (define (alist-delete! key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (elt) (not (= key (car elt)))) alist))) - - (define (lset<= = . lists) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) (rest (cdr rest))) - (and (or (eq? s2 s1) ; Fast path - (%lset2<= = s1 s2)) ; Real test - (lp s2 rest))))))) - - (define (lset= = . lists) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) - (rest (cdr rest))) - (and (or (eq? s1 s2) ; Fast path - (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test - (lp s2 rest))))))) - - (define (lset-adjoin = lis . elts) - (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) - lis elts)) - - (define (lset-union = . lists) - (reduce (lambda (lis ans) ; Compute ANS + LIS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) - ans - (cons elt ans))) - ans lis)))) - '() lists)) - - (define (lset-union! = . lists) - (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (pair-fold (lambda (pair ans) - (let ((elt (car pair))) - (if (any (lambda (x) (= x elt)) ans) - ans - (begin (set-cdr! pair ans) pair)))) - ans lis)))) - '() lists)) - - (define (lset-intersection = lis1 . lists) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut + (span! (lambda (x) + (not (break? x))) + x)) + + (define (delete x xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (filter (lambda (y) + (not (x=? x y))) + xs))) + + (define (delete! x xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (filter! (lambda (y) + (not (x=? x y))) + xs))) + + (define (delete-duplicates xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (let recur ((x:xs xs)) + (if (null-list? x:xs) + '() + (let* ((x (car x:xs)) + (xs (cdr x:xs)) + (ys (recur (delete x xs x=?)))) + (if (eq? xs ys) + x:xs + (cons x ys))))))) + + (define (delete-duplicates! xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (let recur ((x:xs xs)) + (if (null-list? x:xs) + '() + (let* ((x (car x:xs)) + (xs (cdr x:xs)) + (ys (recur (delete! x xs x=?)))) + (if (eq? xs ys) + x:xs + (cons x ys))))))) + + (define (alist-delete key alist . key=?) + (let ((key=? (if (pair? key=?) + (car key=?) + equal?))) + (filter (lambda (x) + (not (key=? key (car x)))) + alist))) + + (define (alist-delete! key alist . key=?) + (let ((key=? (if (pair? key=?) + (car key=?) + equal?))) + (filter! (lambda (x) + (not (key=? key (car x)))) + alist))) + + (define (lset<= x=? . xss) + (or (not (pair? xss)) + (let recur ((xs (car xss)) + (xss (cdr xss))) + (or (not (pair? xss)) + (let ((ys (car xss)) + (xss (cdr xss))) + (and (or (eq? xs ys) + (%lset2<= x=? xs ys)) + (recur ys xss))))))) + + (define (lset= x=? . xss) + (or (not (pair? xss)) + (let recur ((xs (car xss)) + (xss (cdr xss))) + (or (not (pair? xss)) + (let ((ys (car xss)) + (xss (cdr xss))) + (and (or (eq? xs ys) + (and (%lset2<= x=? xs ys) + (%lset2<= x=? ys xs))) + (recur ys xss))))))) + + (define (lset-adjoin x=? xs . ys) + (fold (lambda (y xs) + (if (member y xs x=?) + xs + (cons y xs))) + xs + ys)) + + (define (lset-union x=? . xss) + (reduce (lambda (xs ys) + (cond ((null? xs) ys) + ((null? ys) xs) + ((eq? xs ys) ys) + (else (fold (lambda (x ys) + (if (any (lambda (y) + (x=? x y)) + ys) + ys + (cons x ys))) + ys + xs)))) + '() + xss)) + + (define (lset-union! x=? . xss) + (reduce (lambda (xs ys) + (cond ((null? xs) ys) + ((null? ys) xs) + ((eq? xs ys) ys) + (else (pair-fold (lambda (x:xs ys) + (let ((x (car x:xs))) + (if (any (lambda (y) + (x=? x y)) + ys) + ys + (begin (set-cdr! x:xs ys) + x:xs)))) + ys + xs)))) + '() + xss)) + + (define (lset-intersection x=? xs . xss) + (let ((xss (delete xs xss eq?))) + (cond ((any null-list? xss) '()) + ((null? xss) xs) (else (filter (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - - (define (lset-intersection! = lis1 . lists) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut + (every (lambda (xs) + (member x xs x=?)) + xss)) + xs))))) + + (define (lset-intersection! x=? xs . xss) + (let ((xss (delete xs xss eq?))) + (cond ((any null-list? xss) '()) + ((null? xss) xs) (else (filter! (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - - (define (lset-difference = lis1 . lists) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut + (every (lambda (xs) + (member x xs x=?)) + xss)) + xs))))) + + (define (lset-difference x=? xs . xss) + (let ((xss (filter pair? xss))) + (cond ((null? xss) xs) + ((memq xs xss) '()) (else (filter (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - - (define (lset-difference! = lis1 . lists) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut + (every (lambda (xs) + (not (member x xs x=?))) + xss)) + xs))))) + + (define (lset-difference! x=? xs . xss) + (let ((xss (filter pair? xss))) + (cond ((null? xss) xs) + ((memq xs xss) '()) (else (filter! (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - - (define (lset-xor = . lists) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection = a b) - (cond ((null? a-b) (lset-difference = b a)) - ((null? a-int-b) (append b a)) - (else (fold (lambda (xb ans) - (if (member xb a-int-b =) ans (cons xb ans))) - a-b - b))))) - '() lists)) - - (define (lset-xor! = . lists) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection! = a b) - (cond ((null? a-b) (lset-difference! = b a)) - ((null? a-int-b) (append! b a)) - (else (pair-fold (lambda (b-pair ans) - (if (member (car b-pair) a-int-b =) ans - (begin (set-cdr! b-pair ans) b-pair))) - a-b - b))))) - '() lists)) - - (define (lset-diff+intersection = lis1 . lists) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - - (define (lset-diff+intersection! = lis1 . lists) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition! (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - ) - - (begin ; Return (map cdr lists). - ; However, if any element of LISTS is empty, just abort and return '(). - (define (%cdrs xs) + (every (lambda (xs) + (not (member x xs x=?))) + xss)) + xs))))) + + (define (lset-xor x=? . xss) + (reduce (lambda (b a) + (receive (a-b a^b) (lset-diff+intersection x=? a b) + (cond ((null? a-b) (lset-difference x=? b a)) + ((null? a^b) (append b a)) + (else (fold (lambda (x xs) + (if (member x a^b x=?) + xs + (cons x xs))) + a-b + b))))) + '() + xss)) + + (define (lset-xor! x=? . xss) + (reduce (lambda (b a) + (receive (a-b a^b) (lset-diff+intersection! x=? a b) + (cond ((null? a-b) (lset-difference! x=? b a)) + ((null? a^b) (append! b a)) + (else (pair-fold (lambda (x:xs ys) + (if (member (car x:xs) a^b x=?) + ys + (begin (set-cdr! x:xs ys) + x:xs))) + a-b + b))))) + '() + xss)) + + (define (lset-diff+intersection x=? xs . xss) + (cond ((every null-list? xss) + (values xs '())) + ((memq xs xss) + (values '() xs)) + (else (partition (lambda (x) + (not (any (lambda (xs) + (member x xs x=?)) + xss))) + xs)))) + + (define (lset-diff+intersection! x=? xs . xss) + (cond ((every null-list? xss) + (values xs '())) + ((memq xs xss) + (values '() xs)) + (else (partition! (lambda (x) + (not (any (lambda (xs) + (member x xs x=?)) + xss))) + xs))))) + + (begin (define (%cdrs xss) (call-with-current-continuation! (lambda (abort) - (letrec ((recur (lambda (xs) - (if (pair? xs) - ((lambda (x) - (if (null-list? x) - (abort '()) - (cons (cdr x) - (recur (cdr xs))))) - (car xs)) - '())))) - (recur xs))))) - - (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (letrec ((recur (lambda (lists) - (if (pair? lists) - (cons (caar lists) - (recur (cdr lists))) - (list last-elt))))) - (recur lists))) - - (define (%cars+cdrs lists) + (let recur ((xss xss)) + (if (pair? xss) + (let ((xs (car xss))) + (if (null-list? xs) + (abort '()) + (cons (cdr xs) + (recur (cdr xss))))) + '()))))) + + (define (%cars+ xss cars) + (let recur ((xss xss)) + (if (pair? xss) + (cons (caar xss) + (recur (cdr xss))) + (list cars)))) + + (define (%cars+cdrs xss) (call-with-current-continuation! (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values '() '())))))) - - (define (%cars+cdrs+ lists cars-final) + (let recur ((xss xss)) + (if (pair? xss) + (receive (xs xss) (car+cdr xss) + (if (null-list? xs) + (abort '() + '()) + (receive (a d) (car+cdr xs) + (receive (cars cdrs) (recur xss) + (values (cons a cars) + (cons d cdrs)))))) + (values '() + '())))))) + + (define (%cars+cdrs+ xss cars) (call-with-current-continuation! (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values (list cars-final) '())))))) - - (define (%cars+cdrs/no-test lists) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs))))) - (values '() '())))) - - (define (%lset2<= = lis1 lis2) - (every (lambda (x) (member x lis2 =)) lis1)))) + (let recur ((xss xss)) + (if (pair? xss) + (receive (xs xss) (car+cdr xss) + (if (null-list? xs) + (abort '() + '()) + (receive (a d) (car+cdr xs) + (receive (cars cdrs) (recur xss) + (values (cons a cars) + (cons d cdrs)))))) + (values (list cars) + '())))))) + + (define (%cars+cdrs/no-test xss) + (let recur ((xss xss)) + (if (pair? xss) + (receive (xs xss) (car+cdr xss) + (receive (a d) (car+cdr xs) + (receive (cars cdrs) (recur xss) + (values (cons a cars) + (cons d cdrs))))) + (values '() + '())))) + + (define (%lset2<= x=? xs ys) + (every (lambda (x) + (member x ys x=?)) + xs)))) diff --git a/basis/srfi-39.ss b/basis/srfi-39.ss index 00e047a61..85abb1c21 100644 --- a/basis/srfi-39.ss +++ b/basis/srfi-39.ss @@ -22,8 +22,13 @@ (define-library (srfi 39) (import (only (meevax core) current install) + (only (meevax continuation) dynamic-wind) + (only (meevax core) define define-syntax if lambda letrec quote) + (only (meevax list) null? list append assq) (only (meevax macro-transformer) er-macro-transformer) - (scheme r5rs)) + (only (meevax pair) cons car cdr cadr cddr set-car! set-cdr!) + (only (scheme r5rs) map) + ) (export make-parameter parameterize) @@ -33,36 +38,48 @@ (define (install-dynamic-bindings! bindings) (install 1 bindings)) - (define (make-parameter init . converter) - (let* ((convert (if (null? converter) - (lambda (x) x) - (car converter))) - (default (cons #f (convert init)))) - (letrec ((parameter - (lambda value - (let ((cell (or (assq parameter (current-dynamic-bindings)) default))) - (cond ((null? value) - (cdr cell)) - ((null? (cdr value)) - (set-cdr! cell (convert (car value)))) - (else ; Apply converter to value - (convert (car value)))))))) - (set-car! default parameter) - parameter))) + (define (make-parameter init . convert) + ((lambda (convert) + ((lambda (default) + (letrec ((parameter + (lambda value + ((lambda (cell) + (if (null? value) + (cdr cell) + (if (null? (cdr value)) + (set-cdr! cell (convert (car value))) + (convert (car value))))) + ((lambda (current-dynamic-binding) + (if current-dynamic-binding + current-dynamic-binding + default)) + (assq parameter (current-dynamic-bindings))))))) + (set-car! default parameter) + parameter)) + (cons #f (convert init)))) + (if (null? convert) + (lambda (x) x) + (car convert)))) (define (dynamic-bind parameters values body) - (let* ((outer (current-dynamic-bindings)) - (inner (map (lambda (parameter value) - (cons parameter (parameter value 'apply-converter-to-value))) - parameters - values))) - (dynamic-wind (lambda () (install-dynamic-bindings! (append inner outer))) - body - (lambda () (install-dynamic-bindings! outer))))) + ((lambda (outer inner) + (dynamic-wind (lambda () (install-dynamic-bindings! (append inner outer))) + body + (lambda () (install-dynamic-bindings! outer)))) + (current-dynamic-bindings) + (map (lambda (parameter value) + (cons parameter (parameter value 'convert))) + parameters + values))) (define-syntax parameterize (er-macro-transformer (lambda (form rename compare) - `(,(rename 'dynamic-bind) (,(rename 'list) ,@(map car (cadr form))) - (,(rename 'list) ,@(map cadr (cadr form))) - (,(rename 'lambda) () ,@(cddr form)))))))) + (list (rename 'dynamic-bind) + (cons (rename 'list) + (map car (cadr form))) + (cons (rename 'list) + (map cadr (cadr form))) + (cons (rename 'lambda) + (cons '() + (cddr form))))))))) diff --git a/benchmark/fib.ss b/benchmark/fib.ss new file mode 100644 index 000000000..87dcdb05f --- /dev/null +++ b/benchmark/fib.ss @@ -0,0 +1,15 @@ +(import (scheme base) + (scheme write) + (scheme process-context)) + +(define (fib n) + (if (< n 2) + n + (+ (fib (- n 1)) + (fib (- n 2))))) + +; (fib 20) = 6765 +; (fib 30) = 832040 +; (fib 40) = 102334155 + +(exit (= (fib 30) 832040)) diff --git a/configure/README.md b/configure/README.md index 245acfa70..fae35493a 100644 --- a/configure/README.md +++ b/configure/README.md @@ -46,34 +46,34 @@ Procedures for each standard are provided by the following R7RS-style libraries: |:--------:|--------------| | R4RS | [`(scheme r4rs)`](./basis/r4rs.ss) | R5RS | [`(scheme r5rs)`](./basis/r5rs.ss) -| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) +| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme list)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) ### SRFIs -| Number | Title | Library name | Note | -|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|-----------------------------------| -| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | -| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | -| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | -| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | -| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | -| [ 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 | -| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | -| [ 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 | -| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | -| [ 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 | -| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | -| [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 | +| Number | Title | Library name | Note | +|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|------------------------------------| +| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | +| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | [`(scheme list)`](./basis/r7rs.ss) | +| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | +| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | +| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | +| [ 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 | +| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | +| [ 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 | +| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | +| [ 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 | +| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | +| [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 | ## Installation diff --git a/configure/basis.cmake b/configure/basis.cmake index e22306c1d..32884bc9c 100644 --- a/configure/basis.cmake +++ b/configure/basis.cmake @@ -7,9 +7,7 @@ file(GLOB ${PROJECT_NAME}_BASIS_SOURCES ${TOPLEVEL}/basis/*.ss) foreach(EACH IN LISTS ${PROJECT_NAME}_BASIS_SOURCES) get_filename_component(FILENAME ${EACH} NAME) - execute_process( - COMMAND ${TOPLEVEL}/build/bin/format ${EACH} - OUTPUT_VARIABLE CONFIGURED_${FILENAME}) + file(READ ${EACH} ${FILENAME}) endforeach() configure_file( diff --git a/configure/basis.hpp b/configure/basis.hpp index 423db2e71..eac3bb9ee 100644 --- a/configure/basis.hpp +++ b/configure/basis.hpp @@ -32,28 +32,28 @@ inline namespace kernel constexpr auto basis() { return make_array( - R"##(${CONFIGURED_meevax.ss})##", - R"##(${CONFIGURED_r4rs.ss})##", - R"##(${CONFIGURED_r5rs.ss})##", - R"##(${CONFIGURED_r7rs.ss})##", - R"##(${CONFIGURED_srfi-0.ss})##", - R"##(${CONFIGURED_srfi-1.ss})##", - R"##(${CONFIGURED_srfi-4.ss})##", - R"##(${CONFIGURED_srfi-6.ss})##", - R"##(${CONFIGURED_srfi-8.ss})##", - R"##(${CONFIGURED_srfi-9.ss})##", - R"##(${CONFIGURED_srfi-11.ss})##", - R"##(${CONFIGURED_srfi-16.ss})##", - R"##(${CONFIGURED_srfi-23.ss})##", - R"##(${CONFIGURED_srfi-31.ss})##", - R"##(${CONFIGURED_srfi-34.ss})##", - R"##(${CONFIGURED_srfi-38.ss})##", - R"##(${CONFIGURED_srfi-39.ss})##", - R"##(${CONFIGURED_srfi-45.ss})##", - R"##(${CONFIGURED_srfi-78.ss})##", - R"##(${CONFIGURED_srfi-98.ss})##", - R"##(${CONFIGURED_srfi-111.ss})##", - R"##(${CONFIGURED_srfi-149.ss})##"); + R"##(${meevax.ss})##", + R"##(${r4rs.ss})##", + R"##(${r5rs.ss})##", + R"##(${r7rs.ss})##", + R"##(${srfi-0.ss})##", + R"##(${srfi-1.ss})##", + R"##(${srfi-4.ss})##", + R"##(${srfi-6.ss})##", + R"##(${srfi-8.ss})##", + R"##(${srfi-9.ss})##", + R"##(${srfi-11.ss})##", + R"##(${srfi-16.ss})##", + R"##(${srfi-23.ss})##", + R"##(${srfi-31.ss})##", + R"##(${srfi-34.ss})##", + R"##(${srfi-38.ss})##", + R"##(${srfi-39.ss})##", + R"##(${srfi-45.ss})##", + R"##(${srfi-78.ss})##", + R"##(${srfi-98.ss})##", + R"##(${srfi-111.ss})##", + R"##(${srfi-149.ss})##"); } } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/boolean.hpp b/include/meevax/kernel/boolean.hpp index f73009d42..8a0065fc6 100644 --- a/include/meevax/kernel/boolean.hpp +++ b/include/meevax/kernel/boolean.hpp @@ -24,9 +24,8 @@ namespace meevax inline namespace kernel { let extern const t; - let extern const f; - auto is_truthy(object const&) -> bool; + let extern const f; } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/configurator.hpp b/include/meevax/kernel/configurator.hpp index 6cf2a7b09..ccddd4d83 100644 --- a/include/meevax/kernel/configurator.hpp +++ b/include/meevax/kernel/configurator.hpp @@ -126,11 +126,11 @@ inline namespace kernel auto search = [&](auto&& name) -> auto const& { - if (auto iter = std::find_if(std::begin(options), std::end(options), [&](auto&& option) + if (auto iter = std::find_if(options.begin(), options.end(), [&](auto&& option) { return std::regex_match(name, option.pattern); }); - iter != std::end(options)) + iter != options.end()) { return *iter; } @@ -142,7 +142,7 @@ inline namespace kernel std::vector expressions {}; - for (auto iter = std::next(std::begin(args)); iter != std::end(args); ++iter) + for (auto iter = std::next(args.begin()); iter != args.end(); ++iter) { static std::regex const pattern { R"(--(\w[-\w]+)(?:=(.*))?|-([\w]+))" }; @@ -150,7 +150,7 @@ inline namespace kernel { auto read = [&]() { - if (std::next(iter) != std::cend(args)) + if (std::next(iter) != args.end()) { return input_string_port(*++iter).read(); } diff --git a/include/meevax/kernel/dynamic_environment.hpp b/include/meevax/kernel/dynamic_environment.hpp index aaf2f4b85..9f50c4db6 100644 --- a/include/meevax/kernel/dynamic_environment.hpp +++ b/include/meevax/kernel/dynamic_environment.hpp @@ -220,9 +220,9 @@ inline namespace kernel case instruction::load_continuation: /* -------------------------------- * - * s e (%load-continuation c1 . c2) d => (() . s) e c2 d + * s e (%load-continuation c' . c) d => (() . s) e c d * - * where = (s e c1 . d) + * where = (s e c' . d) * * ----------------------------------------------------------------- */ s = cons(list(make(s, e, cadr(c), d)), s); @@ -256,7 +256,7 @@ inline namespace kernel * where c' = (if c1 c2) * * ----------------------------------------------------------------- */ - c = is_truthy(car(s)) ? cadr(c) : caddr(c); + c = car(s) != f ? cadr(c) : caddr(c); s = cdr(s); goto fetch; diff --git a/include/meevax/kernel/heterogeneous.hpp b/include/meevax/kernel/heterogeneous.hpp index 939e83903..04b22723b 100644 --- a/include/meevax/kernel/heterogeneous.hpp +++ b/include/meevax/kernel/heterogeneous.hpp @@ -51,7 +51,7 @@ inline namespace kernel auto compare([[maybe_unused]] Top const* top) const -> bool override { - if constexpr (is_equality_comparable_v) + if constexpr (is_equality_comparable_v) { if (auto const* bound = dynamic_cast(top); bound) { @@ -75,7 +75,7 @@ inline namespace kernel auto write(std::ostream & os) const -> std::ostream & override { - if constexpr (is_output_streamable_v) + if constexpr (is_output_streamable_v) { return os << static_cast(*this); } @@ -87,7 +87,7 @@ inline namespace kernel auto operator []([[maybe_unused]] std::size_t k) const -> heterogeneous const& override { - if constexpr (is_array_subscriptable_v) + if constexpr (is_array_subscriptable_v) { return static_cast(*this)[k]; } @@ -96,6 +96,18 @@ inline namespace kernel throw std::runtime_error(lexical_cast("no viable array subscript operator for ", demangle(type()))); } } + + auto operator []([[maybe_unused]] std::size_t k) -> heterogeneous & override + { + if constexpr (is_array_subscriptable_v) + { + return static_cast(*this)[k]; + } + else + { + throw std::runtime_error(lexical_cast("no viable array subscript operator for ", demangle(type()))); + } + } }; public: @@ -236,6 +248,18 @@ inline namespace kernel } } + inline auto operator [](std::size_t k) -> heterogeneous & + { + if (dereferenceable() and *this) + { + return get()->operator [](k); + } + else + { + throw std::runtime_error(lexical_cast("no viable array subscript operator for ", demangle(type()))); + } + } + friend auto operator <<(std::ostream & os, heterogeneous const& datum) -> std::ostream & { return datum.write(os); diff --git a/include/meevax/kernel/input_homogeneous_vector_port.hpp b/include/meevax/kernel/input_homogeneous_vector_port.hpp index 00e83c2b8..e448a3eb9 100644 --- a/include/meevax/kernel/input_homogeneous_vector_port.hpp +++ b/include/meevax/kernel/input_homogeneous_vector_port.hpp @@ -61,8 +61,8 @@ inline namespace kernel } else { - let const v = make>(std::begin(deque), std::next(std::begin(deque), size)); - deque.erase(std::begin(deque), std::next(std::begin(deque), size)); + let const v = make>(deque.begin(), std::next(deque.begin(), size)); + deque.erase(deque.begin(), std::next(deque.begin(), size)); return v; } } diff --git a/include/meevax/kernel/instruction.hpp b/include/meevax/kernel/instruction.hpp index 4aaa0751b..0a9f68c72 100644 --- a/include/meevax/kernel/instruction.hpp +++ b/include/meevax/kernel/instruction.hpp @@ -52,7 +52,43 @@ inline namespace kernel auto operator <<(std::ostream &, instruction const&) -> std::ostream &; - auto instruction_length(instruction const&) -> std::size_t; + constexpr auto size(instruction const& datum) + { + switch (datum) + { + case instruction::call: + case instruction::cons: + case instruction::drop: + case instruction::dummy: + case instruction::join: + case instruction::letrec: + case instruction::return_: + case instruction::stop: + case instruction::tail_call: + case instruction::tail_letrec: + return 1; + + case instruction::current: + case instruction::install: + case instruction::load_absolute: + case instruction::load_closure: + case instruction::load_constant: + case instruction::load_continuation: + case instruction::load_relative: + case instruction::load_variadic: + case instruction::store_absolute: + case instruction::store_relative: + case instruction::store_variadic: + return 2; + + case instruction::select: + case instruction::tail_select: + return 3; + + default: + return 0; + } + } } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/list.hpp b/include/meevax/kernel/list.hpp index 3b8b6c0cd..887e59413 100644 --- a/include/meevax/kernel/list.hpp +++ b/include/meevax/kernel/list.hpp @@ -18,6 +18,7 @@ #define INCLUDED_MEEVAX_KERNEL_LIST_HPP #include +#include namespace meevax { @@ -90,27 +91,62 @@ inline namespace kernel inline auto cons = [](auto&&... xs) constexpr { - return (xs | ...); + return (std::forward(xs) | ...); }; inline auto list = [](auto&&... xs) constexpr { - return (xs | ... | unit); + return (std::forward(xs) | ... | unit); }; - inline auto xcons = [](auto&& d, auto&& a) constexpr + inline auto xcons = [](auto&& x, auto&& y) constexpr { - return cons(std::forward(a), std::forward(d)); + return cons(std::forward(y), + std::forward(x)); }; auto make_list(std::size_t, object const& = unit) -> object; + auto iota(std::size_t, object const& = e0, object const& = e1) -> object; + + template + auto last_pair(T&& x) -> decltype(x) + { + return cdr(x).template is() ? last_pair(cdr(std::forward(x))) : std::forward(x); + } + + template + auto last(T&& x) -> decltype(x) + { + return car(last_pair(std::forward(x))); + } + + template + auto circulate(T&& x) + { + cdr(last_pair(std::forward(x))) = x; + } + + template + auto circular_list(Ts&&... xs) + { + let x = list(std::forward(xs)...); + circulate(x); + return x; + } + auto is_list(object const&) -> bool; + auto is_circular_list(object const&) -> bool; + + auto is_dotted_list(object const&) -> bool; + + auto list_copy(object const&) -> object; + template auto tail(T&& x, std::size_t size) -> decltype(x) { - return 0 < size ? tail(cdr(std::forward(x)), --size) : x; + return 0 < size ? tail(cdr(std::forward(x)), --size) : std::forward(x); } template @@ -119,27 +155,38 @@ inline namespace kernel return car(tail(std::forward(xs)...)); } - auto last(object const&) -> object const&; - auto take(object const&, std::size_t) -> object; + auto take(object &, std::size_t) -> object; + + auto take_right(object const&, std::size_t) -> object const&; + + auto drop(object const&, std::size_t) -> object const&; + + auto drop(object &, std::size_t) -> object &; + + auto drop_right(object const&, std::size_t) -> object; + + auto drop_right(object &, std::size_t) -> object; + auto length(object const&) -> std::size_t; auto append(object const&, object const&) -> object; - auto reverse(object const&, object const& = unit) -> object; + auto append(object &, object const&) -> object &; + + auto append_reverse(object const&, object const&) -> object; + + auto append_reverse(object &, object const&) -> object; + + auto reverse(object const&) -> object; + + auto reverse(object &) -> object; template auto map(F f, object const& xs) -> object { - if (xs.is()) - { - return cons(f(car(xs)), map(f, cdr(xs))); - } - else - { - return unit; - } + return xs.is() ? cons(f(car(xs)), map(f, cdr(xs))) : unit; } auto memq(object const&, object const&) -> object const&; @@ -150,6 +197,10 @@ inline namespace kernel auto assv(object const&, object const&) -> object const&; + auto alist_cons(object const&, object const&, object const&) -> object; + + auto alist_copy(object const&) -> object; + template auto filter(F test, object const& xs) -> object { diff --git a/include/meevax/kernel/optimizer.hpp b/include/meevax/kernel/optimizer.hpp index 14facd586..fb5fa0068 100644 --- a/include/meevax/kernel/optimizer.hpp +++ b/include/meevax/kernel/optimizer.hpp @@ -29,11 +29,11 @@ inline namespace kernel static auto merge_constants(object const& c) -> object { - if (not c.is()) + if (not c.is() or not c[0].is()) { return c; } - else switch (c[0].as()) + else switch (auto n = size(c[0].as()); c[0].as()) { case instruction::load_constant: /* -------------------------------------- * @@ -42,70 +42,64 @@ inline namespace kernel * cons * ...) * - * => (load-constant (x . y) + * => (load-constant (y . x) * ...) * * --------------------------------------------------------------------- */ - if (5 <= length(c) and - c[0].is() and - c[0].as() == instruction::load_constant and - c[2].is() and - c[2].as() == instruction::load_constant and - c[4].is() and - c[4].as() == instruction::cons) + if (tail(c, 2).is() and c[2].is() and c[2].as() == instruction::load_constant and + tail(c, 4).is() and c[4].is() and c[4].as() == instruction::cons) { return merge_constants(cons(c[0], cons(c[3], c[1]), merge_constants(tail(c, 5)))); } - else if (let const& continuation = merge_constants(cddr(c)); continuation == cddr(c)) + else if (let const& c2 = merge_constants(tail(c, 2)); c2 == tail(c, 2)) { return c; } else { - return cons(car(c), cadr(c), continuation); + return cons(c[0], c[1], c2); + } + + default: + if (let const& cn = merge_constants(tail(c, n)); cn == tail(c, n)) + { + return c; + } + else + { + return append(take(c, n), cn); } case instruction::load_closure: case instruction::load_continuation: - if (let const& subcontrol = merge_constants(cadr(c)), - continuation = merge_constants(cddr(c)); - subcontrol == cadr(c) and continuation == cddr(c)) + if (let const& c1 = merge_constants(head(c, 1)), + c2 = merge_constants(tail(c, 2)); + c1 == head(c, 1) and + c2 == tail(c, 2)) { return c; } else { - return cons(c[0], subcontrol, continuation); + return cons(c[0], c1, c2); } case instruction::select: case instruction::tail_select: - if (let const& consequent = merge_constants(cadr(c)), - alternate = merge_constants(caddr(c)), - continuation = merge_constants(cdddr(c)); - consequent == cadr(c) and alternate == caddr(c) and continuation == cdddr(c)) + if (let const& c1 = merge_constants(head(c, 1)), + c2 = merge_constants(head(c, 2)), + c3 = merge_constants(tail(c, 3)); + c1 == head(c, 1) and + c2 == head(c, 2) and + c3 == tail(c, 3)) { return c; } else { - return cons(c[0], consequent, alternate, continuation); - } - - default: - { - auto length = instruction_length(c[0].as()); - - if (let const& continuation = merge_constants(tail(c, length)); continuation == tail(c, length)) - { - return c; - } - else - { - return append(take(c, length), continuation); - } + return cons(c[0], c1, c2, c3); } } } diff --git a/include/meevax/kernel/pair.hpp b/include/meevax/kernel/pair.hpp index 6157bf986..614470329 100644 --- a/include/meevax/kernel/pair.hpp +++ b/include/meevax/kernel/pair.hpp @@ -52,14 +52,14 @@ inline namespace kernel struct pair : public std::pair { - template + template struct forward_iterator { using iterator_category = std::forward_iterator_tag; using value_type = object; - using reference = std::add_lvalue_reference_t, value_type>>; + using reference = std::add_lvalue_reference_t, value_type>>; using pointer = std::add_pointer_t; @@ -67,7 +67,7 @@ inline namespace kernel using size_type = std::size_t; - using node_type = std::conditional_t; + using node_type = std::conditional_t; node_type current = nullptr; @@ -92,7 +92,7 @@ inline namespace kernel auto operator ++() -> decltype(auto) { - if (current = current->second.get(); current == initial) + if (current = current->second.get(); current == initial or (current and current->type() != typeid(pair))) { current = nullptr; } @@ -141,6 +141,8 @@ inline namespace kernel virtual auto operator [](std::size_t) const -> object const&; + virtual auto operator [](std::size_t) -> object &; + constexpr auto begin() noexcept { return iterator(this); diff --git a/include/meevax/kernel/syntactic_environment.hpp b/include/meevax/kernel/syntactic_environment.hpp index 9bb728b36..61417f644 100644 --- a/include/meevax/kernel/syntactic_environment.hpp +++ b/include/meevax/kernel/syntactic_environment.hpp @@ -190,17 +190,17 @@ inline namespace kernel * call to one of their arguments. Exceptions are noted in the individual * descriptions. * - * Note: In contrast to other dialects of Lisp, the order of evaluation + * NOTE: In contrast to other dialects of Lisp, the order of evaluation * is unspecified, and the operator expression and the operand * expressions are always evaluated with the same evaluation rules. * - * Note: Although the order of evaluation is otherwise unspecified, the + * NOTE: Although the order of evaluation is otherwise unspecified, the * effect of any concurrent evaluation of the operator and operand * expressions is constrained to be consistent with some sequential order * of evaluation. The order of evaluation may be chosen differently for * each procedure call. * - * Note: In many dialects of Lisp, the empty list, (), is a legitimate + * NOTE: In many dialects of Lisp, the empty list, (), is a legitimate * expression evaluating to itself. In Scheme, it is an error. * * ------------------------------------------------------------------ */ @@ -519,7 +519,7 @@ inline namespace kernel * difference between the two is that include-ci reads each file as if it * began with the #!fold-case directive, while include does not. * - * Note: Implementations are encouraged to search for files in the + * NOTE: Implementations are encouraged to search for files in the * directory which contains the including file, and to provide a way for * users to specify other directories to search. * @@ -997,7 +997,7 @@ inline namespace kernel } else if (expression.is()) { - if (let const& identity = std::as_const(*this).identify(expression, bound_variables, free_variables); is_truthy(identity)) // The syntactic-closure is an alias + if (let const& identity = std::as_const(*this).identify(expression, bound_variables, free_variables); identity != f) // The syntactic-closure is an alias { return syntax::reference(*this, expression, bound_variables, free_variables, continuation, tail); } @@ -1016,7 +1016,7 @@ inline namespace kernel free_variables); }); - xs = cons(cons(free_variable, inject), xs); + xs = alist_cons(free_variable, inject, xs); } return xs; @@ -1115,7 +1115,7 @@ inline namespace kernel { return f; } - else if (let const& x = assq(variable, free_variables); is_truthy(x)) + else if (let const& x = assq(variable, free_variables); x != f) { return cdr(x).as()(bound_variables); } @@ -1169,7 +1169,7 @@ inline namespace kernel { return f; } - else if (let const& identity = std::as_const(*this).identify(variable, bound_variables, free_variables); is_truthy(identity)) + else if (let const& identity = std::as_const(*this).identify(variable, bound_variables, free_variables); identity != f) { return identity; } diff --git a/include/meevax/kernel/vector.hpp b/include/meevax/kernel/vector.hpp index fb8a7215f..c257161ad 100644 --- a/include/meevax/kernel/vector.hpp +++ b/include/meevax/kernel/vector.hpp @@ -39,6 +39,8 @@ inline namespace kernel {} auto operator [](std::size_t) const -> object const&; + + auto operator [](std::size_t) -> object &; }; auto operator ==(heterogeneous_vector const&, heterogeneous_vector const&) -> bool; diff --git a/include/meevax/memory/collector.hpp b/include/meevax/memory/collector.hpp index d9a7d2fc9..e8e9dec6e 100644 --- a/include/meevax/memory/collector.hpp +++ b/include/meevax/memory/collector.hpp @@ -85,7 +85,7 @@ inline namespace memory { return cache; } - else if (auto iter = headers.lower_bound(reinterpret_cast(data)); iter != std::begin(headers) and (*--iter)->contains(data)) + else if (auto iter = headers.lower_bound(reinterpret_cast(data)); iter != headers.begin() and (*--iter)->contains(data)) { return *iter; } diff --git a/include/meevax/memory/pointer_set.hpp b/include/meevax/memory/pointer_set.hpp index 9a0f9d615..ee88d719f 100644 --- a/include/meevax/memory/pointer_set.hpp +++ b/include/meevax/memory/pointer_set.hpp @@ -18,6 +18,7 @@ #define INCLUDED_MEEVAX_MEMORY_POINTER_SET_HPP #include +#include #include #include #include @@ -75,27 +76,15 @@ inline namespace memory } }; - struct chunk + struct chunk : public std::array { std::size_t offset; - bool data[Capacity]; - explicit constexpr chunk(compact_pointer const p) - : offset { p.offset() } - , data { false } - { - data[p.index()] = true; - } - - constexpr auto operator [](std::size_t index) const noexcept -> decltype(auto) + : std::array { false } + , offset { p.offset() } { - return data[index]; - } - - constexpr auto operator [](std::size_t index) noexcept -> decltype(auto) - { - return data[index]; + (*this)[p.index()] = true; } constexpr auto operator <(compact_pointer p) noexcept @@ -121,13 +110,15 @@ inline namespace memory std::vector const& chunks; - std::size_t i, j; + std::size_t i; + + std::size_t j; explicit iterator(std::vector const& chunks, - std::size_t i, + typename std::vector::const_iterator iter, std::size_t j) noexcept : chunks { chunks } - , i { i } + , i { static_cast(std::distance(chunks.begin(), iter)) } , j { j } { if (not (i < chunks.size() and j < Capacity and chunks[i][j])) @@ -260,7 +251,7 @@ inline namespace memory auto begin() const noexcept { - return iterator(chunks, 0, 0); + return iterator(chunks, chunks.begin(), 0); } auto end() const noexcept @@ -272,7 +263,7 @@ inline namespace memory { if (auto iter = lower_bound_chunk(p); iter != chunks.end()) { - return iterator(chunks, std::distance(chunks.begin(), iter), p.index()); + return iterator(chunks, iter, p.index()); } else { diff --git a/include/meevax/memory/unsigned_integer_set.hpp b/include/meevax/memory/unsigned_integer_set.hpp deleted file mode 100644 index 79c516e09..000000000 --- a/include/meevax/memory/unsigned_integer_set.hpp +++ /dev/null @@ -1,200 +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_MEMORY_UNSIGNED_INTEGER_SET_HPP -#define INCLUDED_MEEVAX_MEMORY_UNSIGNED_INTEGER_SET_HPP - -#include -#include -#include -#include -#include - -namespace meevax -{ -inline namespace memory -{ - template - constexpr auto log2(N n) -> std::size_t - { - return n <= 2 ? 1 : log2(n / 2) + 1; - } - - class unsigned_integer_set - { - std::size_t size; - - std::vector data; - - static constexpr auto digits = std::numeric_limits::digits; - - constexpr auto index_of(std::size_t value) - { - return value / digits; - }; - - constexpr auto mark_of(std::size_t value) - { - return static_cast(1) << (value - digits * index_of(value)); - }; - - public: - struct iterator - { - using iterator_category = std::forward_iterator_tag; - - using value_type = std::uint64_t; - - using difference_type = std::ptrdiff_t; - - std::uint64_t const* data; - - std::size_t size; - - std::size_t index; - - std::size_t bit; - - explicit iterator(std::vector const& bitset) - : data { bitset.data() } - , size { bitset.size() } - , index { 0 } - , bit { 0 } - { - if (not valid()) - { - operator ++(); - } - } - - explicit iterator() - : data { nullptr } - , size { 0 } - , index { std::numeric_limits::max() } - , bit { 0 } - {} - - auto valid() const -> bool - { - return (data[index] >> bit) & 1; - } - - auto operator *() const - { - return index * digits + bit; - } - - auto operator ++() -> iterator & - { - do - { - if (digits <= ++bit) - { - bit = 0; - - if (size <= ++index) - { - index = std::numeric_limits::max(); - return *this; - } - } - } - while (not valid()); - - return *this; - } - - auto operator ++(int) -> auto - { - auto copy = *this; - operator ++(); - return copy; - } - - auto operator ==(iterator const& rhs) - { - return index == rhs.index and bit == rhs.bit; - } - - auto operator !=(iterator const& rhs) - { - return not operator ==(rhs); - } - }; - - explicit unsigned_integer_set() - : size { 0 } - , data {} - {} - - auto resize(std::size_t given_size) - { - size = given_size; - data.resize(size / digits + 1); - } - - auto insert(std::uint64_t value) - { - if (data.size() < index_of(value)) - { - resize(value); - } - - data[index_of(value)] |= mark_of(value); - } - - auto erase(std::uint64_t value) - { - data[index_of(value)] &= ~mark_of(value); - } - - auto erase(iterator iter) - { - erase(*iter); - return ++iter; - } - - auto clear() - { - std::fill(std::begin(data), std::end(data), 0); - } - - auto begin() const - { - return iterator(data); - } - - auto end() const - { - return iterator(); - } - - template - auto lower_bound(Ts&&... xs) - { - return std::lower_bound(begin(), end(), std::forward(xs)...); - } - - template - auto upper_bound(Ts&&... xs) - { - return std::upper_bound(begin(), end(), std::forward(xs)...); - } - }; -} // namespace memory -} // namespace meevax - -#endif // INCLUDED_MEEVAX_MEMORY_UNSIGNED_INTEGER_SET_HPP diff --git a/include/meevax/utility/debug.hpp b/include/meevax/utility/debug.hpp index 623b23cd8..5ebdf551a 100644 --- a/include/meevax/utility/debug.hpp +++ b/include/meevax/utility/debug.hpp @@ -21,9 +21,9 @@ #include #define LINE() \ - std::cout << "; \x1b[33m" __FILE__ "\x1b[31m:\x1b[36m" << __LINE__ << "\x1b[0m" << std::endl + std::cerr << "; \x1b[33m" __FILE__ "\x1b[31m:\x1b[36m" << __LINE__ << "\x1b[0m" << std::endl #define PRINT(...) \ - std::cout << "; " #__VA_ARGS__ " = " << std::boolalpha << (__VA_ARGS__) << std::endl + std::cerr << "; " #__VA_ARGS__ " = " << std::boolalpha << (__VA_ARGS__) << std::endl #endif // INCLUDED_MEEVAX_UTILITY_DEBUG_HPP diff --git a/include/meevax/utility/hexdump.hpp b/include/meevax/utility/hexdump.hpp index bc80f344a..da7a1227e 100644 --- a/include/meevax/utility/hexdump.hpp +++ b/include/meevax/utility/hexdump.hpp @@ -40,8 +40,8 @@ inline namespace utility // TODO UPDATE WITH STD::ENDIAN (C++20) auto operator()(std::ostream & os) const -> std::ostream & { - for (auto iter = std::rbegin(data); iter != std::rend(data); ++iter) // little endian - // for (auto iter = std::begin(data); iter != std::end(data); ++iter) // big endian + for (auto iter = data.rbegin(); iter != data.rend(); ++iter) // little endian + // for (auto iter = data.begin(); iter != data.end(); ++iter) // big endian { os << std::setw(2) << std::setfill('0') << std::hex << static_cast(*iter) << " "; } diff --git a/script/benchmark.sh b/script/benchmark.sh index 6d3e81e6e..4201d0d2c 100755 --- a/script/benchmark.sh +++ b/script/benchmark.sh @@ -5,6 +5,7 @@ root="$(git rev-parse --show-toplevel)" scripts() { echo ack + echo fib echo tarai } @@ -20,19 +21,19 @@ quotient() tsv() { - printf "script\tMeevax\tGauche\tChibi\n" + printf "script\tMeevax\tChibi-Scheme\tGauche\n" for each in $(scripts) do - time_m=$(real meevax "$root/benchmark/$each.ss") - time_g=$(real gosh "$root/benchmark/$each.ss") - time_c=$(real chibi-scheme "$root/benchmark/$each.ss") + t0=$(real meevax "$root/benchmark/$each.ss") + t1=$(real chibi-scheme "$root/benchmark/$each.ss") + t2=$(real gosh "$root/benchmark/$each.ss") printf "%s\t%s\t%s\t%s\n" \ "$each" \ - "$time_m" \ - "$time_g ($(quotient "$time_m" "$time_g"))" \ - "$time_c ($(quotient "$time_m" "$time_c"))" + "$t0" \ + "$t1 (x$(quotient "$t0" "$t1"))" \ + "$t2 (x$(quotient "$t0" "$t2"))" done } diff --git a/src/kernel/boolean.cpp b/src/kernel/boolean.cpp index 210edafa4..b5493203d 100644 --- a/src/kernel/boolean.cpp +++ b/src/kernel/boolean.cpp @@ -22,11 +22,7 @@ namespace meevax inline namespace kernel { let const t = make(true); - let const f = make(false); - auto is_truthy(object const& x) -> bool - { - return not eq(x, f); - } + let const f = make(false); } // namespace kernel } // namespace meevax diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 9c1f08869..605ff0ba1 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -48,7 +48,7 @@ inline namespace kernel library.define("not", [](let const& xs) { - return not is_truthy(xs[0]); + return xs[0] == f; }); }); @@ -283,7 +283,7 @@ inline namespace kernel } else if (let const& status = car(xs); status.is()) { - throw is_truthy(status) ? EXIT_SUCCESS : EXIT_FAILURE; + throw status != f ? EXIT_SUCCESS : EXIT_FAILURE; } else { @@ -558,7 +558,73 @@ inline namespace kernel library.define("make-list", [](let const& xs) { - return make_list(xs[0].as(), 1 < length(xs) ? xs[1] : f); + switch (length(xs)) + { + case 1: + return make_list(xs[0].as()); + + case 2: + return make_list(xs[0].as(), xs[1]); + + default: + throw error(make("procedure make-list takes one or two arugments, but got"), xs); + } + }); + + library.define("iota", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return iota(xs[0].as()); + + case 2: + return iota(xs[0].as(), xs[1]); + + case 3: + return iota(xs[0].as(), xs[1], xs[2]); + + default: + throw error(make("procedure iota takes one to three arugments, but got"), xs); + } + }); + + library.define("circular-list?", [](let const& xs) + { + return is_circular_list(xs[0]); + }); + + library.define("circular-list", [](let & xs) + { + circulate(xs); + return xs; + }); + + library.define("dotted-list?", [](let const& xs) + { + return is_dotted_list(xs[0]); + }); + + library.define("null-list?", [](let const& xs) + { + if (is_list(xs[0]) or is_circular_list(xs[0])) + { + return xs[0].is(); + } + else + { + throw error(make("procedure null-list? takes a proper-list or a circular-list, but got"), xs); + } + }); + + library.define("last", [](let const& xs) -> auto const& + { + return last(xs[0]); + }); + + library.define("last-pair", [](let const& xs) -> auto const& + { + return last_pair(xs[0]); }); library.define("length", [](let const& xs) @@ -566,9 +632,29 @@ inline namespace kernel return make(length(xs[0])); }); + library.define("length+", [](let const& xs) + { + return is_circular_list(xs[0]) ? f : make(length(xs[0])); + }); + library.define("append", [](let const& xs) { - return std::accumulate(std::begin(xs), std::end(xs), unit, append); + return std::accumulate(xs.begin(), xs.end(), unit, [](let const& x, let const& y) { return append(x, y); }); + }); + + library.define("append!", [](let & xs) + { + return std::accumulate(xs.begin(), xs.end(), unit, [](let & x, let const& y) { return append(x, y); }); + }); + + library.define("append-reverse", [](let const& xs) + { + return append_reverse(xs[0], xs[1]); + }); + + library.define("append-reverse!", [](let & xs) + { + return append_reverse(xs[0], xs[1]); }); library.define("reverse", [](let const& xs) @@ -576,6 +662,26 @@ inline namespace kernel return reverse(xs[0]); }); + library.define("reverse!", [](let & xs) + { + return reverse(xs[0]); + }); + + library.define("concatenate", [](let const& xs) + { + return std::accumulate(xs[0].begin(), xs[0].end(), unit, [](let const& x, let const& y) { return append(x, y); }); + }); + + library.define("concatenate!", [](let & xs) + { + return std::accumulate(xs[0].begin(), xs[0].end(), unit, [](let & x, let const& y) { return append(x, y); }); + }); + + library.define("list-copy", [](let const& xs) + { + return list_copy(xs[0]); + }); + library.define("list-tail", [](let const& xs) -> auto const& { return tail(xs[0], xs[1].as()); @@ -586,6 +692,86 @@ inline namespace kernel return xs[0][xs[1].as()]; }); + library.define("first", [](let const& xs) -> decltype(auto) + { + return xs[0][0]; + }); + + library.define("second", [](let const& xs) -> decltype(auto) + { + return xs[0][1]; + }); + + library.define("third", [](let const& xs) -> decltype(auto) + { + return xs[0][2]; + }); + + library.define("fourth", [](let const& xs) -> decltype(auto) + { + return xs[0][3]; + }); + + library.define("fifth", [](let const& xs) -> decltype(auto) + { + return xs[0][4]; + }); + + library.define("sixth", [](let const& xs) -> decltype(auto) + { + return xs[0][5]; + }); + + library.define("seventh", [](let const& xs) -> decltype(auto) + { + return xs[0][6]; + }); + + library.define("eighth", [](let const& xs) -> decltype(auto) + { + return xs[0][7]; + }); + + library.define("ninth", [](let const& xs) -> decltype(auto) + { + return xs[0][8]; + }); + + library.define("tenth", [](let const& xs) -> decltype(auto) + { + return xs[0][9]; + }); + + library.define("take", [](let const& xs) + { + return take(xs[0], xs[1].as()); + }); + + library.define("take!", [](let & xs) + { + return take(xs[0], xs[1].as()); + }); + + library.define("take-right", [](let const& xs) + { + return take_right(xs[0], xs[1].as()); + }); + + library.define("drop", [](let const& xs) + { + return drop(xs[0], xs[1].as()); + }); + + library.define("drop-right", [](let const& xs) + { + return drop_right(xs[0], xs[1].as()); + }); + + library.define("drop-right!", [](let & xs) + { + return drop_right(xs[0], xs[1].as()); + }); + library.define("memq", [](let const& xs) -> auto const& { return memq(xs[0], xs[1]); @@ -605,6 +791,16 @@ inline namespace kernel { return assv(xs[0], xs[1]); }); + + library.define("alist-cons", [](let const& xs) + { + return alist_cons(xs[0], xs[1], xs[2]); + }); + + library.define("alist-copy", [](let const& xs) + { + return alist_copy(xs[0]); + }); }); define("(meevax number)", [](library & library) @@ -651,27 +847,27 @@ inline namespace kernel library.define("=", [](let const& xs) { - return std::adjacent_find(std::begin(xs), std::end(xs), not_equals) == std::end(xs); + return std::adjacent_find(xs.begin(), xs.end(), not_equals) == xs.end(); }); library.define("<", [](let const& xs) { - return std::adjacent_find(std::begin(xs), std::end(xs), greater_than_or_equals) == std::end(xs); + return std::adjacent_find(xs.begin(), xs.end(), greater_than_or_equals) == xs.end(); }); library.define("<=", [](let const& xs) { - return std::adjacent_find(std::begin(xs), std::end(xs), greater_than) == std::end(xs); + return std::adjacent_find(xs.begin(), xs.end(), greater_than) == xs.end(); }); library.define(">", [](let const& xs) { - return std::adjacent_find(std::begin(xs), std::end(xs), less_than_or_equals) == std::end(xs); + return std::adjacent_find(xs.begin(), xs.end(), less_than_or_equals) == xs.end(); }); library.define(">=", [](let const& xs) { - return std::adjacent_find(std::begin(xs), std::end(xs), less_than) == std::end(xs); + return std::adjacent_find(xs.begin(), xs.end(), less_than) == xs.end(); }); library.define("zero?", [](let const& xs) @@ -711,19 +907,19 @@ inline namespace kernel library.define("+", [](let const& xs) { - return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); + return std::accumulate(xs.begin(), xs.end(), e0, std::plus()); }); library.define("*", [](let const& xs) { - return std::accumulate(std::begin(xs), std::end(xs), e1, std::multiplies()); + return std::accumulate(xs.begin(), xs.end(), e1, std::multiplies()); }); library.define("-", [](let const& xs) { if (cdr(xs).is()) { - return std::accumulate(std::next(std::begin(xs)), std::end(xs), xs[0], std::minus()); + return std::accumulate(std::next(xs.begin()), xs.end(), xs[0], std::minus()); } else { @@ -735,7 +931,7 @@ inline namespace kernel { if (cdr(xs).is()) { - return std::accumulate(std::next(std::begin(xs)), std::end(xs), xs[0], std::divides()); + return std::accumulate(std::next(xs.begin()), xs.end(), xs[0], std::divides()); } else { @@ -884,11 +1080,46 @@ inline namespace kernel return xs[0].is(); }); + library.define("not-pair?", [](let const& xs) + { + return not xs[0].is(); + }); + library.define("cons", [](let const& xs) { return cons(xs[0], xs[1]); }); + library.define("cons*", [](let & xs) + { + if (xs.is()) + { + throw error(make("procedure cons* takes at least one arugments, but got"), xs); + } + else if (cdr(xs).is()) + { + return xs[0]; + } + else + { + auto node = xs.get(); + + while (not cddr(*node).is()) + { + node = cdr(*node).get(); + } + + cdr(*node) = cadr(*node); + + return xs; + } + }); + + library.define("xcons", [](let const& xs) + { + return cons(xs[1], xs[0]); + }); + library.define("car", [](let const& xs) -> auto const& { return car(xs[0]); }); library.define("cdr", [](let const& xs) -> auto const& { return cdr(xs[0]); }); @@ -1536,9 +1767,9 @@ inline namespace kernel { 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); + alist = alist_cons(make(std::string(*iter, position)), + make(std::string(*iter + position + 1)), + alist); } } @@ -1598,7 +1829,7 @@ inline namespace kernel library.define("vector-set!", [](let & xs) { - xs[0].as().vector[xs[1].as()] = xs[2]; + xs[0][xs[1].as()] = xs[2]; }); library.define("vector->list", [](let const& xs) diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 83c4f00d4..c5a8d8fce 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -119,7 +119,7 @@ inline namespace kernel return filter([&](let const& identity) { assert(identity.is()); - return is_truthy(memq(car(identity), identities)); + return memq(car(identity), identities) != f; }, resolve(import_set)); }; @@ -141,7 +141,7 @@ inline namespace kernel return filter([&](let const& identity) { assert(identity.is()); - return not is_truthy(memq(car(identity), identities)); + return memq(car(identity), identities) == f; }, resolve(import_set)); }; @@ -189,7 +189,7 @@ inline namespace kernel assert(identity.is()); assert(car(identity).is_also()); - if (let const& renaming = assq(car(identity), renamings); is_truthy(renaming)) + if (let const& renaming = assq(car(identity), renamings); renaming != f) { assert(cadr(renaming).is()); return make(cadr(renaming), cdr(identity)); @@ -206,7 +206,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 != libraries().end()) { return std::get<1>(*iter).resolve(); } @@ -218,18 +218,17 @@ inline namespace kernel auto environment::import(object const& import_set) -> void { - for (let const& identity : resolve(import_set)) + for (let const& immigrant : resolve(import_set)) { - assert(identity.is()); + assert(immigrant.is()); - if (not is_truthy(std::as_const(*this).identify(car(identity), unit, unit)) or interactive) + if (let const& inhabitant = std::as_const(*this).identify(car(immigrant), unit, unit); inhabitant == f or interactive) { - define(car(identity), - cdr(identity)); + second = cons(immigrant, second); } - else + else if (immigrant != inhabitant) { - throw error(make("in a program or library declaration, it is an error to import the same identifier more than once with different bindings"), identity); + throw error(make("in a program or library declaration, it is an error to import the same identifier more than once with different bindings"), immigrant); } } } diff --git a/src/kernel/implementation_dependent.cpp b/src/kernel/implementation_dependent.cpp index b48ee114b..acaa6eedb 100644 --- a/src/kernel/implementation_dependent.cpp +++ b/src/kernel/implementation_dependent.cpp @@ -27,15 +27,17 @@ inline namespace kernel { if (car(requirement).as() == "library") { - return libraries().find(lexical_cast(cadr(requirement))) != std::end(libraries()); + return libraries().find(lexical_cast(cadr(requirement))) != libraries().end(); } else if (car(requirement).as() == "and") { - return std::all_of(std::begin(cdr(requirement)), std::end(cdr(requirement)), test); + return std::all_of(cdr(requirement).begin(), + cdr(requirement).end(), test); } else if (car(requirement).as() == "or") { - return std::any_of(std::begin(cdr(requirement)), std::end(cdr(requirement)), test); + return std::any_of(cdr(requirement).begin(), + cdr(requirement).end(), test); } else if (car(requirement).as() == "not") { @@ -48,7 +50,7 @@ inline namespace kernel } else { - return eq(requirement, make_symbol("else")) or is_truthy(memq(requirement, features())); + return requirement == make_symbol("else") or memq(requirement, features()) != f; } } diff --git a/src/kernel/instruction.cpp b/src/kernel/instruction.cpp index 09469e96f..f2cb1ada6 100644 --- a/src/kernel/instruction.cpp +++ b/src/kernel/instruction.cpp @@ -55,44 +55,5 @@ inline namespace kernel return os; } } - - auto instruction_length(instruction const& datum) -> std::size_t - { - switch (datum) - { - case instruction::call: - case instruction::cons: - case instruction::drop: - case instruction::dummy: - case instruction::join: - case instruction::letrec: - case instruction::return_: - case instruction::stop: - case instruction::tail_call: - case instruction::tail_letrec: - return 1; - - case instruction::current: - case instruction::install: - case instruction::load_absolute: - case instruction::load_closure: - case instruction::load_constant: - case instruction::load_continuation: - case instruction::load_relative: - case instruction::load_variadic: - case instruction::store_absolute: - case instruction::store_relative: - case instruction::store_variadic: - return 2; - - case instruction::select: - case instruction::tail_select: - return 3; - - default: - assert(false); - return 0; - } - } } // namespace kernel } // namespace meevax diff --git a/src/kernel/list.cpp b/src/kernel/list.cpp index 174c8cc08..2789fc490 100644 --- a/src/kernel/list.cpp +++ b/src/kernel/list.cpp @@ -23,7 +23,26 @@ inline namespace kernel { auto make_list(std::size_t size, object const& x) -> object { - return 0 < size ? cons(x, make_list(--size, x)) : unit; + if (0 < size) + { + return cons(x, make_list(--size, x)); + } + else + { + return unit; + } + } + + auto iota(std::size_t count, object const& start, object const& step) -> object + { + if (0 < count) + { + return cons(start, iota(count - 1, start + step, step)); + } + else + { + return unit; + } } auto is_list(object const& x0, object const& y0) -> bool @@ -53,19 +72,183 @@ inline namespace kernel return is_list(xs, xs); } - auto last(object const& xs) -> object const& + auto is_circular_list(object const& x0, object const& y0) -> bool + { + if (x0.is()) + { + if (let const& x1 = cdr(x0); x1.is()) + { + let const& x2 = cdr(x1), + y1 = cdr(y0); + + return eq(x2, y1) or is_circular_list(x2, y1); + } + else + { + return false; + } + } + else + { + return false; + } + } + + auto is_circular_list(object const& xs) -> bool { - return cdr(xs).is() ? last(cdr(xs)) : car(xs); + return is_circular_list(xs, xs); } - auto take(object const& x, std::size_t size) -> object + auto is_dotted_list(object const& x0, object const& y0) -> bool { - return 0 < size ? cons(car(x), take(cdr(x), --size)) : unit; + if (x0.is()) + { + if (let const& x1 = cdr(x0); x1.is()) + { + let const& x2 = cdr(x1), + y1 = cdr(y0); + + return not eq(x2, y1) and is_dotted_list(x2, y1); + } + else + { + return not x1.is(); + } + } + else + { + return not x0.is(); + } } - auto length(object const& xs) -> std::size_t + auto is_dotted_list(object const& xs) -> bool { - return std::distance(xs.begin(), xs.end()); + return is_dotted_list(xs, xs); + } + + auto list_copy(object const& xs) -> object + { + if (xs.is()) + { + return cons(car(xs), list_copy(cdr(xs))); + } + else + { + return xs; + } + } + + auto take(object const& x, std::size_t k) -> object + { + if (0 < k) + { + return cons(car(x), take(cdr(x), k - 1)); + } + else + { + return unit; + } + } + + auto take(object & x, std::size_t k) -> object + { + if (0 < k) + { + cdr(drop(x, k - 1)) = unit; + return x; + } + else + { + return unit; + } + } + + auto take_right(object const& x, object const& y) -> object const& + { + if (y.is()) + { + return take_right(cdr(x), cdr(y)); + } + else + { + return x; + } + } + + auto take_right(object const& x, std::size_t k) -> object const& + { + return take_right(x, drop(x, k)); + } + + auto drop(object const& x, std::size_t k) -> object const& + { + if (0 < k) + { + return drop(cdr(x), k - 1); + } + else + { + return x; + } + } + + auto drop(object & x, std::size_t k) -> object & + { + if (0 < k) + { + return drop(cdr(x), k - 1); + } + else + { + return x; + } + } + + auto drop_right(object const& x, object const& y) -> object + { + if (y.is()) + { + return cons(car(x), drop_right(cdr(x), cdr(y))); + } + else + { + return unit; + } + } + + auto drop_right(object const& x, std::size_t k) -> object + { + return drop_right(x, drop(x, k)); + } + + auto drop_right(object & x, object const& y) -> void + { + if (y.is()) + { + drop_right(cdr(x), cdr(y)); + } + else + { + cdr(x) = unit; + } + } + + auto drop_right(object & x, std::size_t k) -> object + { + if (let const y = drop(x, k); y.is()) + { + drop_right(x, cdr(y)); + return x; + } + else + { + return unit; + } + } + + auto length(object const& x) -> std::size_t + { + return std::distance(x.begin(), x.end()); } auto append(object const& x, object const& y) -> object @@ -80,6 +263,51 @@ inline namespace kernel } } + auto append(object & x, object const& y) -> object & + { + if (x.is()) + { + return x = y; + } + else if (y.is()) + { + return x; + } + else + { + cdr(last_pair(x)) = y; + return x; + } + } + + auto append_reverse(object const& x, object const& y) -> object + { + if (x.is()) + { + return y; + } + else + { + return append_reverse(cdr(x), cons(car(x), y)); + } + } + + auto append_reverse(object & x, object const& y) -> object + { + if (x.is()) + { + return y; + } + else + { + let const cdr_x = cdr(x); + + cdr(x) = y; + + return append_reverse(cdr_x, x); + } + } + auto reverse(object const& xs, object const& a) -> object { if (xs.is()) @@ -92,6 +320,32 @@ inline namespace kernel } } + auto reverse(object const& xs) -> object + { + return reverse(xs, unit); + } + + auto reverse(object & xs, object const& a) -> object + { + if (xs.is()) + { + return a; + } + else + { + let tail = cdr(xs); + + cdr(xs) = a; + + return reverse(tail, xs); + } + } + + auto reverse(object & xs) -> object + { + return reverse(xs, unit); + } + auto memq(object const& x, object const& xs) -> object const& { if (xs.is()) @@ -168,6 +422,20 @@ inline namespace kernel } } + auto alist_cons(object const& key, object const& datum, object const& alist) -> object + { + return cons(cons(key, datum), alist); + } + + auto alist_copy(object const& alist) -> object + { + return map([](auto&& x) + { + return cons(car(x), cdr(x)); + }, + alist); + } + auto longest_common_tail(let const& a, let const& b) -> object const& { if (a.is() or b.is() or eq(a, b)) diff --git a/src/kernel/number.cpp b/src/kernel/number.cpp index 0b227bbb5..eee4e2efd 100644 --- a/src/kernel/number.cpp +++ b/src/kernel/number.cpp @@ -463,7 +463,7 @@ inline namespace kernel auto static const pattern = std::regex(R"(([+-]?(?:\d+\.?|\d*\.\d+))([DEFLSdefls][+-]?\d+)?)"); - if (auto iter = constants.find(literal); iter != std::end(constants)) + if (auto iter = constants.find(literal); iter != constants.end()) { return make(iter->second); } diff --git a/src/kernel/pair.cpp b/src/kernel/pair.cpp index 79227c57b..3dfc20da4 100644 --- a/src/kernel/pair.cpp +++ b/src/kernel/pair.cpp @@ -46,22 +46,14 @@ inline namespace kernel return 0 < k ? second[--k] : first; } - auto operator <<(std::ostream & os, pair const& datum) -> std::ostream & + auto pair::operator [](std::size_t k) -> object & { - auto is_circular_list = [&]() - { - for (auto rest = datum.second.get(); rest; rest = rest->second.get()) - { - if (rest == &datum) - { - return true; - } - } - - return false; - }; + return 0 < k ? second[--k] : first; + } - if (is_circular_list()) + auto operator <<(std::ostream & os, pair const& datum) -> std::ostream & + { + if (is_circular_list(cdr(datum))) { auto n = reinterpret_cast(&datum); diff --git a/src/kernel/string.cpp b/src/kernel/string.cpp index faac4c640..8a6cc8f87 100644 --- a/src/kernel/string.cpp +++ b/src/kernel/string.cpp @@ -52,8 +52,8 @@ inline namespace kernel auto operator ==(string const& s1, string const& s2) -> bool { - return std::equal(std::begin(s1.vector), std::end(s1.vector), - std::begin(s2.vector), std::end(s2.vector)); + return std::equal(s1.vector.begin(), s1.vector.end(), + s2.vector.begin(), s2.vector.end()); } auto operator <<(std::ostream & os, string const& datum) -> std::ostream & diff --git a/src/kernel/symbol.cpp b/src/kernel/symbol.cpp index e0c44eceb..0426dad78 100644 --- a/src/kernel/symbol.cpp +++ b/src/kernel/symbol.cpp @@ -59,7 +59,7 @@ inline namespace kernel 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 != symbols().end()) { return iter->second; } diff --git a/src/kernel/textual_input_port.cpp b/src/kernel/textual_input_port.cpp index 9fba2fba0..7b3de16ed 100644 --- a/src/kernel/textual_input_port.cpp +++ b/src/kernel/textual_input_port.cpp @@ -264,7 +264,7 @@ inline namespace kernel case '#': ignore(1); - if (auto iter = datum_labels.find(label); iter != std::end(datum_labels)) + if (auto iter = datum_labels.find(label); iter != datum_labels.end()) { return iter->second; } @@ -497,7 +497,7 @@ inline namespace kernel auto name = static_cast(character(c)) + take_token(); - if (auto iter = names.find(name); iter != std::end(names)) + if (auto iter = names.find(name); iter != names.end()) { return character(iter->second); } diff --git a/src/kernel/vector.cpp b/src/kernel/vector.cpp index 0eb1b7597..4beeb73e6 100644 --- a/src/kernel/vector.cpp +++ b/src/kernel/vector.cpp @@ -27,7 +27,7 @@ inline namespace kernel { heterogeneous_vector::heterogeneous_vector(object const& x) { - std::copy(std::begin(x), std::end(x), std::back_inserter(vector)); + std::copy(x.begin(), x.end(), std::back_inserter(vector)); } heterogeneous_vector::heterogeneous_vector(std::size_t size, object const& x) @@ -39,10 +39,15 @@ inline namespace kernel return vector[index]; } + auto heterogeneous_vector::operator [](std::size_t index) -> object & + { + return vector[index]; + } + auto operator ==(heterogeneous_vector const& v, heterogeneous_vector const& u) -> bool { - return std::equal(std::begin(v.vector), std::end(v.vector), - std::begin(u.vector), std::end(u.vector), equal); + return std::equal(v.vector.begin(), v.vector.end(), + u.vector.begin(), u.vector.end(), equal); } auto operator <<(std::ostream & output, heterogeneous_vector const& datum) -> std::ostream & diff --git a/src/main.cpp b/src/main.cpp index b4e9aaab3..33a6a6424 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -29,6 +29,7 @@ auto main(int const argc, char const* const* const argv) -> int if (e.configure(argc, argv); e.interactive) { e.import("(scheme base)"_r); + e.import("(scheme box)"_r); e.import("(scheme case-lambda)"_r); e.import("(scheme char)"_r); e.import("(scheme complex)"_r); @@ -37,6 +38,7 @@ auto main(int const argc, char const* const* const argv) -> int e.import("(scheme file)"_r); e.import("(scheme inexact)"_r); e.import("(scheme lazy)"_r); + e.import("(scheme list)"_r); e.import("(scheme load)"_r); e.import("(scheme process-context)"_r); e.import("(scheme read)"_r); diff --git a/src/memory/collector.cpp b/src/memory/collector.cpp index 42ac7ec10..2416d0637 100644 --- a/src/memory/collector.cpp +++ b/src/memory/collector.cpp @@ -66,7 +66,7 @@ inline namespace memory { marker::clear(); - auto is_root_object = [begin = std::begin(headers)](registration * given) + auto is_root_object = [begin = headers.begin()](registration * given) { /* If the given registration is a non-root object, then an object @@ -106,7 +106,7 @@ inline namespace memory const auto lower_address = reinterpret_cast(header->lower_address()); const auto upper_address = reinterpret_cast(header->upper_address()); - for (auto iter = registry.lower_bound(lower_address); iter != std::end(registry) and *iter < upper_address; ++iter) + for (auto iter = registry.lower_bound(lower_address); iter != registry.end() and *iter < upper_address; ++iter) { mark((*iter)->header); } diff --git a/test/collector.cpp b/test/collector.cpp index 928ee9314..18c1dfca2 100644 --- a/test/collector.cpp +++ b/test/collector.cpp @@ -139,18 +139,6 @@ auto main() -> int assert(gc.count() == gc_count + 3); - auto circular_list = [](auto&&... xs) - { - let x = list(std::forward(xs)...); - - if (auto const length = std::distance(std::cbegin(x), std::cend(x)); 0 < length) - { - cdr(std::next(std::begin(x), length - 1)) = x; - } - - return x; - }; - return circular_list(a, b, c); }; diff --git a/test/list.cpp b/test/list.cpp index 3a0f928d6..c67f8911a 100644 --- a/test/list.cpp +++ b/test/list.cpp @@ -33,7 +33,7 @@ auto main() -> int { let x = list(a, b, c); - for (auto iter = std::begin(x); iter != std::end(x); ++iter) + for (auto iter = x.begin(); iter != x.end(); ++iter) { assert((*iter).template is()); } @@ -42,18 +42,16 @@ auto main() -> int { let x = list(a, b, c); - for (auto iter = std::begin(x); iter != std::end(x); ++iter) + for (auto iter = x.begin(); iter != x.end(); ++iter) { assert(iter->template is()); } } { - let x = list(a, b); - cddr(x) = x; + let x = circular_list(a, b); - let y = list(a, b, a, b); - cddddr(y) = y; + let y = circular_list(a, b, a, b); assert(equal(x, y)); } diff --git a/test/srfi-1.ss b/test/srfi-1.ss new file mode 100644 index 000000000..5fe09ed9f --- /dev/null +++ b/test/srfi-1.ss @@ -0,0 +1,422 @@ +(import (scheme base) + (scheme cxr) + (scheme process-context) + (scheme write) + (srfi 1) + (srfi 78)) + +(check (cons 'a 'b) => '(a . b)) + +(check (list 'a 'b 'c) => '(a b c)) + +(check (xcons 'a 'b) => '(b . a)) + +(check (cons* 'a) => 'a) +(check (cons* 'a 'b) => '(a . b)) +(check (cons* 'a 'b 'c) => '(a b . c)) + +(check (make-list 2 'a) => '(a a)) + +(check (list-tabulate 4 (lambda (x) x)) => '(0 1 2 3)) +(check (list-tabulate 4 number->string) => '("0" "1" "2" "3")) + +(check (list-copy '(a b c)) => '(a b c)) + +(check (circular-list 'a) => '#1=(a . #1#)) +(check (circular-list 'a 'b) => '#1=(a b . #1#)) +(check (circular-list 'a 'b 'c) => '#1=(a b c . #1#)) + +(check (iota 5) => '(0 1 2 3 4)) +(check (iota 5 0 -0.1) (=> (lambda (x y) (list= = x y))) '(0 -0.1 -0.2 -0.3 -0.4)) + +(check (pair? 'a) => #f) +(check (pair? '(a . b)) => #t) +(check (pair? '(a b . c)) => #t) +(check (pair? '(a b c)) => #t) + +(check (null? '()) => #t) +(check (null? '(a)) => #f) +(check (null? '(a . b)) => #f) +(check (null? '(a b . c)) => #f) +(check (null? 'a) => #f) +(check (null? 1) => #f) + +(check (proper-list? '()) => #t) +(check (proper-list? '(a . b)) => #f) +(check (proper-list? '(a b . c)) => #f) +(check (proper-list? '(a b c)) => #t) +(check (proper-list? 'a) => #f) +(check (proper-list? 1) => #f) + +(check (circular-list? '(a b c)) => #f) +(check (circular-list? '#1=(a b c . #1#)) => #t) + +(check (dotted-list? '(a . b)) => #t) +(check (dotted-list? '(a b . c)) => #t) +(check (dotted-list? '(a b c)) => #f) + +(check (not-pair? 'a) => #t) +(check (not-pair? '(a . b)) => #f) +(check (not-pair? '(a b . c)) => #f) +(check (not-pair? '(a b c)) => #f) + +(check (null-list? '()) => #t) +(check (null-list? '(a b c)) => #f) +(check (null-list? '#1=(a b c . #1#)) => #f) + +(check (list= eq? '(a b c) '(a b c)) => #t) +(check (list= eq? '(a b c) '(a B c)) => #f) +(check (list= eqv? '(1 2 3) '(1.0 2.0 3.0)) => #f) +(check (list= = '(1 2 3) '(1.0 2.0 3.0)) => #t) +(check (list= eqv? '((a b) (c d) (e f)) '((a b) (c d) (e f))) => #f) +(check (list= equal? '((a b) (c d) (e f)) '((a b) (c d) (e f))) => #t) + +(check (car '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda)) +(check (cdr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) +(check (caar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aaaa . daaa) adaa . ddaa)) +(check (cadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aaad . daad) adad . ddad)) +(check (cdar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aada . dada) adda . ddda)) +(check (cddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aadd . dadd) addd . dddd)) +(check (caaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aaaa . daaa)) +(check (caadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aaad . daad)) +(check (cadar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aada . dada)) +(check (caddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aadd . dadd)) +(check (cdaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(adaa . ddaa)) +(check (cdadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(adad . ddad)) +(check (cddar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(adda . ddda)) +(check (cdddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(addd . dddd)) +(check (caaaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aaaa) +(check (caaadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aaad) +(check (caadar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aada) +(check (caaddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aadd) +(check (cadaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'adaa) +(check (cadadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'adad) +(check (caddar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'adda) +(check (cadddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'addd) +(check (cdaaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'daaa) +(check (cdaadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'daad) +(check (cdadar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'dada) +(check (cdaddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'dadd) +(check (cddaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'ddaa) +(check (cddadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'ddad) +(check (cdddar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'ddda) +(check (cddddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'dddd) + +(let ((x '(1 2 3 4 5 6 7 8 9 10))) + (let recurse ((i 0)) + (if (< i (length x)) + (begin (check (list-ref x i) => (+ i 1)) + (recurse (+ i 1)))))) + +(check (first '(a b c d e f g h i j)) => 'a) +(check (second '(a b c d e f g h i j)) => 'b) +(check (third '(a b c d e f g h i j)) => 'c) +(check (fourth '(a b c d e f g h i j)) => 'd) +(check (fifth '(a b c d e f g h i j)) => 'e) +(check (sixth '(a b c d e f g h i j)) => 'f) +(check (seventh '(a b c d e f g h i j)) => 'g) +(check (eighth '(a b c d e f g h i j)) => 'h) +(check (ninth '(a b c d e f g h i j)) => 'i) +(check (tenth '(a b c d e f g h i j)) => 'j) + +(call-with-values (lambda () + (car+cdr '(a . b))) + (lambda (x y) + (check x => 'a) + (check y => 'b))) + +(let ((x '(a b c d e))) (check (take x 0) => '()) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 0) => '()) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take x 1) => '(a)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 1) => '(a)) (check x => '(a))) +(let ((x '(a b c d e))) (check (take x 2) => '(a b)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 2) => '(a b)) (check x => '(a b))) +(let ((x '(a b c d e))) (check (take x 3) => '(a b c)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 3) => '(a b c)) (check x => '(a b c))) +(let ((x '(a b c d e))) (check (take x 4) => '(a b c d)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 4) => '(a b c d)) (check x => '(a b c d))) +(let ((x '(a b c d e))) (check (take x 5) => '(a b c d e)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 5) => '(a b c d e)) (check x => '(a b c d e))) + +(check (drop '(a b c d e) 0) => '(a b c d e)) +(check (drop '(a b c d e) 1) => '(b c d e)) +(check (drop '(a b c d e) 2) => '(c d e)) +(check (drop '(a b c d e) 3) => '(d e)) +(check (drop '(a b c d e) 4) => '(e)) +(check (drop '(a b c d e) 5) => '()) + +(check (take-right '(a b c d e) 0) => '()) +(check (take-right '(a b c d e) 1) => '(e)) +(check (take-right '(a b c d e) 2) => '(d e)) +(check (take-right '(a b c d e) 3) => '(c d e)) +(check (take-right '(a b c d e) 4) => '(b c d e)) +(check (take-right '(a b c d e) 5) => '(a b c d e)) +(check (take-right '(a b c . x) 0) => 'x) +(check (take-right '(a b c . x) 1) => '(c . x)) +(check (take-right '(a b c . x) 2) => '(b c . x)) +(check (take-right '(a b c . x) 3) => '(a b c . x)) + +(let ((x '(a b c d e))) (check (drop-right x 0) => '(a b c d e)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 0) => '(a b c d e)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right x 1) => '(a b c d)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 1) => '(a b c d)) (check x => '(a b c d))) +(let ((x '(a b c d e))) (check (drop-right x 2) => '(a b c)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 2) => '(a b c)) (check x => '(a b c))) +(let ((x '(a b c d e))) (check (drop-right x 3) => '(a b)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 3) => '(a b)) (check x => '(a b))) +(let ((x '(a b c d e))) (check (drop-right x 4) => '(a)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 4) => '(a)) (check x => '(a))) +(let ((x '(a b c d e))) (check (drop-right x 5) => '()) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 5) => '()) (check x => '(a b c d e))) +(let ((x '(a b c . z))) (check (drop-right x 0) => '(a b c)) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 0) => '(a b c)) (check x => '(a b c))) +(let ((x '(a b c . z))) (check (drop-right x 1) => '(a b)) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 1) => '(a b)) (check x => '(a b))) +(let ((x '(a b c . z))) (check (drop-right x 2) => '(a)) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 2) => '(a)) (check x => '(a))) +(let ((x '(a b c . z))) (check (drop-right x 3) => '()) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 3) => '()) (check x => '(a b c . z))) + +(let ((x '(a b c d e f g h))) (check (call-with-values (lambda () (split-at x 3)) (lambda (x xs) (list x xs))) => '((a b c) (d e f g h))) (check x => '(a b c d e f g h))) +(let ((x '(a b c d e f g h))) (check (call-with-values (lambda () (split-at! x 3)) (lambda (x xs) (list x xs))) => '((a b c) (d e f g h))) (check x => '(a b c))) + +(check (last '(a)) => 'a) +(check (last '(a b)) => 'b) +(check (last '(a b c)) => 'c) + +(check (last-pair '(a)) => '(a)) +(check (last-pair '(a b)) => '(b)) +(check (last-pair '(a b c)) => '(c)) +(check (last-pair '(a b c . d)) => '(c . d)) + +(check (length '(a b c)) => 3) +(check (length '(a b . c)) => 2) + +(check (length+ '(a b c)) => 3) +(check (length+ '(a b . c)) => 2) +(check (length+ '#1=(a b c . #1#)) => #f) + +(let ((x '(a)) (y '(b))) (check (append x y) => '(a b)) (check x => '(a)) (check y => '(b))) +(let ((x '(a)) (y '(b))) (check (append! x y) => '(a b)) (check x => '(a b)) (check y => '(b))) +(let ((x '(a)) (y '(b c d))) (check (append x y) => '(a b c d)) (check x => '(a)) (check y => '(b c d))) +(let ((x '(a)) (y '(b c d))) (check (append! x y) => '(a b c d)) (check x => '(a b c d)) (check y => '(b c d))) +(let ((x '(a (b))) (y '((c)))) (check (append x y) => '(a (b) (c))) (check x => '(a (b))) (check y => '((c)))) +(let ((x '(a (b))) (y '((c)))) (check (append! x y) => '(a (b) (c))) (check x => '(a (b) (c))) (check y => '((c)))) +(let ((x '(a b)) (y '(c . d))) (check (append x y) => '(a b c . d)) (check x => '(a b)) (check y => '(c . d))) +(let ((x '(a b)) (y '(c . d))) (check (append! x y) => '(a b c . d)) (check x => '(a b c . d)) (check y => '(c . d))) +(let ((x '()) (y 'a)) (check (append x y) => 'a) (check x => '()) (check y => 'a)) +(let ((x '()) (y 'a)) (check (append! x y) => 'a) (check x => '()) (check y => 'a)) + +(check (append '(a b)) => '(a b)) +(check (append! '(a b)) => '(a b)) +(check (append) => '()) +(check (append!) => '()) + +(let ((x '((1 2 3) (4 5 6) (7 8 9)))) (check (concatenate x) => '(1 2 3 4 5 6 7 8 9)) (check x => '((1 2 3) (4 5 6) (7 8 9)))) +(let ((x '((1 2 3) (4 5 6) (7 8 9)))) (check (concatenate! x) => '(1 2 3 4 5 6 7 8 9)) (check x => '((1 2 3 4 5 6 7 8 9) (4 5 6 7 8 9) (7 8 9)))) +(let ((x '((1 2 3) (4 5 6) (7 . ...)))) (check (concatenate x) => '(1 2 3 4 5 6 7 . ...)) (check x => '((1 2 3) (4 5 6) (7 . ...)))) +(let ((x '((1 2 3) (4 5 6) (7 . ...)))) (check (concatenate! x) => '(1 2 3 4 5 6 7 . ...)) (check x => '((1 2 3 4 5 6 7 . ...) (4 5 6 7 . ...) (7 . ...)))) +(let ((x '((1 2 3) (4 5 6) ...))) (check (concatenate x) => '(1 2 3 4 5 6 . ...)) (check x => '((1 2 3) (4 5 6) ...))) +(let ((x '((1 2 3) (4 5 6) ...))) (check (concatenate! x) => '(1 2 3 4 5 6 . ...)) (check x => '((1 2 3 4 5 6 . ...) (4 5 6 . ...) ...))) + +(let ((x '(a b c))) (check (reverse x) => '(c b a)) (check x => '(a b c))) +(let ((x '(a b c))) (check (reverse! x) => '(c b a)) (check x => '(a))) +(let ((x '(a (b c) d (e (f))))) (check (reverse x) => '((e (f)) d (b c) a)) (check x => '(a (b c) d (e (f))))) +(let ((x '(a (b c) d (e (f))))) (check (reverse! x) => '((e (f)) d (b c) a)) (check x => '(a))) + +(let ((x '(3 2 1)) (y '(4 5 6))) (check (append-reverse x y) => '(1 2 3 4 5 6)) (check x => '(3 2 1)) (check y => '(4 5 6))) +(let ((x '(3 2 1)) (y '(4 5 6))) (check (append-reverse! x y) => '(1 2 3 4 5 6)) (check x => '(3 4 5 6)) (check y => '(4 5 6))) + +(check (zip '(one two three) '(1 2 3) '(odd even odd even odd even odd even)) => '((one 1 odd) (two 2 even) (three 3 odd))) +(check (zip '(1 2 3)) => '((1) (2) (3))) +(check (zip '(3 1 4 1) (circular-list #f #t)) => '((3 #f) (1 #t) (4 #f) (1 #t))) + +(call-with-values (lambda () (unzip1 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5))))) +(call-with-values (lambda () (unzip2 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five))))) +(call-with-values (lambda () (unzip3 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five) (ONE TWO THREE FOUR FIVE))))) +(call-with-values (lambda () (unzip4 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five) (ONE TWO THREE FOUR FIVE) (a b c d e))))) +(call-with-values (lambda () (unzip5 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five) (ONE TWO THREE FOUR FIVE) (a b c d e) (A B C D E))))) + +(check (count even? '(3 1 4 1 5 9 2 5 6)) => 3) +(check (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)) => 3) +(check (count < '(3 1 4 1) (circular-list 1 10)) => 2) + +(check (fold + 0 '(1 2 3 4 5 6 7 8 9 10)) => 55) +(check (fold cons '() '(a b c)) => '(c b a)) +(check (fold cons* '() '(a b c) '(1 2 3 4 5)) => '(c 3 b 2 a 1)) +(check (fold (lambda (x k) (if (symbol? x) (+ k 1) k)) 0 '(1 a 2 b 3 c)) => 3) +(check (fold (lambda (s k) (max k (string-length s))) 0 '("one" "two" "three")) => 5) + +(check (fold-right cons '() '(a b c)) => '(a b c)) +(check (fold-right cons* '() '(a b c) '(1 2 3 4 5)) => '(a 1 b 2 c 3)) +(check (fold-right (lambda (x xs) (if (even? x) (cons x xs) xs)) '() '(1 2 3 4 5)) => '(2 4)) + +(check (pair-fold (lambda (x xs) (set-cdr! x xs) x) '() '(a b c)) => '(c b a)) + +(check (pair-fold-right cons '() '(a b c)) => '((a b c) (b c) (c))) + +(check (reduce max 42 '(1 2 3 4 5 6 7 8 9 10)) => 10) +(check (reduce max 42 '(1)) => 1) +(check (reduce max 42 '()) => 42) + +(check (reduce-right append '() '((a b c) (d e f) (g h i))) => '(a b c d e f g h i)) +(check (reduce-right append '(x y z) '((a b c) (d e f) (g h i))) => '(a b c d e f g h i)) +(check (reduce-right append '(x y z) '((a b c))) => '(a b c)) +(check (reduce-right append '(x y z) '()) => '(x y z)) + +(check (unfold (lambda (x) (< 10 x)) square (lambda (x) (+ x 1)) 1) => '(1 4 9 16 25 36 49 64 81 100)) +(check (unfold null-list? car cdr '(a b c)) => '(a b c)) +(check (unfold not-pair? car cdr '(a b c) values) => '(a b c)) +(check (unfold not-pair? car cdr '(a b c . d) values) => '(a b c . d)) +(check (unfold null-list? car cdr '(a b c) (lambda (x) '(d e f))) => '(a b c d e f)) + +(check (unfold-right zero? square (lambda (x) (- x 1)) 10) => '(1 4 9 16 25 36 49 64 81 100)) +(check (unfold-right null-list? car cdr '(a b c)) => '(c b a)) +(check (unfold-right null-list? car cdr '(c b a) '(d e f)) => '(a b c d e f)) + +(check (map cadr '((a b) (d e) (g h))) => '(b e h)) +(check (map! cadr '((a b) (d e) (g h))) => '(b e h)) +(check (map-in-order cadr '((a b) (d e) (g h))) => '(b e h)) +(check (map (lambda (n) (expt n n)) '(1 2 3 4 5)) => '(1 4 27 256 3125)) +(check (map! (lambda (n) (expt n n)) '(1 2 3 4 5)) => '(1 4 27 256 3125)) +(check (map-in-order (lambda (n) (expt n n)) '(1 2 3 4 5)) => '(1 4 27 256 3125)) +(check (map + '(1 2 3) '(4 5 6)) => '(5 7 9)) +(check (map! + '(1 2 3) '(4 5 6)) => '(5 7 9)) +(check (map-in-order + '(1 2 3) '(4 5 6)) => '(5 7 9)) +(check (map + '(3 1 4 1) (circular-list 1 0)) => '(4 1 5 1)) +(check (map! + '(3 1 4 1) (circular-list 1 0)) => '(4 1 5 1)) +(check (map-in-order + '(3 1 4 1) (circular-list 1 0)) => '(4 1 5 1)) +(check (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b))) => '(1 2)) +(check (let ((count 0)) (map! (lambda (ignored) (set! count (+ count 1)) count) '(a b))) => '(1 2)) +(check (let ((count 0)) (map-in-order (lambda (ignored) (set! count (+ count 1)) count) '(a b))) => '(1 2)) + +(check (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v) => #(0 1 4 9 16)) + +(check (append-map! (lambda (x) (list x (- x))) '(1 3 8)) => '(1 -1 3 -3 8 -8)) + +(check (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)) => '(1 9 49)) + +(check (parameterize ((current-output-port (open-output-string ""))) + (pair-for-each (lambda (pair) + (display pair)) + '(a b c)) + (get-output-string (current-output-port))) + => "(a b c)(b c)(c)") + +(check (filter even? '(0 7 8 8 43 -4)) => '(0 8 8 -4)) +(check (filter! even? '(0 7 8 8 43 -4)) => '(0 8 8 -4)) + +(call-with-values (lambda () (partition symbol? '(one 2 3 four five 6))) (lambda (x y) (check x => '(one four five)) (check y => '(2 3 6)))) +(call-with-values (lambda () (partition! symbol? '(one 2 3 four five 6))) (lambda (x y) (check x => '(one four five)) (check y => '(2 3 6)))) + +(check (remove even? '(0 7 8 8 43 -4)) => '(7 43)) +(check (remove! even? '(0 7 8 8 43 -4)) => '(7 43)) + +(check (find even? '(3 1 4 1 5 9)) => 4) + +(check (find-tail even? '(3 1 37 -8 -5 0 0)) => '(-8 -5 0 0)) +(check (find-tail even? '(3 1 37 -5)) => #f) + +(check (take-while even? '(2 18 3 10 22 9)) => '(2 18)) +(check (take-while! even? '(2 18 3 10 22 9)) => '(2 18)) +(check (drop-while even? '(2 18 3 10 22 9)) => '(3 10 22 9)) + +(call-with-values (lambda () (span even? '(2 18 3 10 22 9))) (lambda (x y) (check x => '(2 18)) (check y => '(3 10 22 9)))) +(call-with-values (lambda () (span! even? '(2 18 3 10 22 9))) (lambda (x y) (check x => '(2 18)) (check y => '(3 10 22 9)))) + +(call-with-values (lambda () (break even? '(3 1 4 1 5 9))) (lambda (x y) (check x => '(3 1)) (check y => '(4 1 5 9)))) +(call-with-values (lambda () (break! even? '(3 1 4 1 5 9))) (lambda (x y) (check x => '(3 1)) (check y => '(4 1 5 9)))) + +(check (any integer? '(a 3 b 2.7)) => #t) +(check (any integer? '(a 3.1 b 2.7)) => #f) +(check (any < '(3 1 4 1 5) '(2 7 1 8 2)) => #t) + +(check (every integer? '(1 2 3)) => #t) +(check (every integer? '(1 2 3.14)) => #f) +(check (every integer? '(1 2 3) '(4 5 6 7)) => #t) +(check (every integer? '(1 2 3) '(4 5 6 7.0)) => #t) +(check (every integer? '(1 2 3) (circular-list 4)) => #t) + +(check (list-index even? '(3 1 4 1 5 9)) => 2) +(check (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)) => 1) +(check (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)) => #f) + +(check (memq 'a '(a b c)) => '(a b c)) +(check (memq 'b '(a b c)) => '(b c)) +(check (memq 'a '(b c d)) => #f) +(check (memq (list 'a) '(b (a) c)) => #f) +(check (member (list 'a) '(b (a) c)) => '((a) c)) +(check (memq 101 '(100 101 102)) => #f) +(check (memv 101 '(100 101 102)) => '(101 102)) + +(check (delete 2 '(1 2 3)) => '(1 3)) +(check (delete! 2 '(1 2 3)) => '(1 3)) + +(check (delete-duplicates '(a b a c a b c z)) => '(a b c z)) +(check (delete-duplicates! '(a b a c a b c z)) => '(a b c z)) +(check (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y)))) => '((a . 3) (b . 7) (c . 1))) +(check (delete-duplicates! '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y)))) => '((a . 3) (b . 7) (c . 1))) + +(check (assq 'a '((a 1) (b 2) (c 3))) => '(a 1)) +(check (assq 'b '((a 1) (b 2) (c 3))) => '(b 2)) +(check (assq 'd '((a 1) (b 2) (c 3))) => #f) +(check (assq (list 'a) '(((a)) ((b)) ((c)))) => #f) +(check (assoc (list 'a) '(((a)) ((b)) ((c)))) => '((a))) +(check (assq 5 '((2 3) (5 7) (11 13))) => #f) +(check (assv 5 '((2 3) (5 7) (11 13))) => '(5 7)) + +(check (alist-cons 'a 1 '((b . 2) (c . 3))) => '((a . 1) (b . 2) (c . 3))) + +(check (alist-copy '((a . 1) (b . 2) (c . 3))) => '((a . 1) (b . 2) (c . 3))) + +(check (alist-delete 'a '((a 1) (b 2) (c 3))) => '((b 2) (c 3))) +(check (alist-delete! 'a '((a 1) (b 2) (c 3))) => '((b 2) (c 3))) +(check (alist-delete 'b '((a 1) (b 2) (c 3))) => '((a 1) (c 3))) +(check (alist-delete! 'b '((a 1) (b 2) (c 3))) => '((a 1) (c 3))) +(check (alist-delete 'c '((a 1) (b 2) (c 3))) => '((a 1) (b 2))) +(check (alist-delete! 'c '((a 1) (b 2) (c 3))) => '((a 1) (b 2))) + +(check (lset= eq? '(b e a) '(a e b) '(e e b a)) => #t) +(check (lset= eq? '(a)) => #t) +(check (lset= eq?) => #t) + +(check (lset<= eq? '(a) '(a b a) '(a b c c)) => #t) +(check (lset<= eq? '(a)) => #t) +(check (lset<= eq?) => #t) + +(check (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u) => '(u o i a b c d c e)) + +(check (lset-union eq? '(a b c d e) '(a e i o u)) => '(u o i a b c d e)) +(check (lset-union! eq? '(a b c d e) '(a e i o u)) => '(u o i a b c d e)) +(check (lset-union eq? '(a a c) '(x a x)) => '(x a a c)) +(check (lset-union! eq? '(a a c) '(x a x)) => '(x a a c)) +(check (lset-union eq?) => '()) +(check (lset-union! eq?) => '()) +(check (lset-union eq? '(a b c)) => '(a b c)) +(check (lset-union! eq? '(a b c)) => '(a b c)) + +(check (lset-intersection eq? '(a b c d e) '(a e i o u)) => '(a e)) +(check (lset-intersection! eq? '(a b c d e) '(a e i o u)) => '(a e)) +(check (lset-intersection eq? '(a x y a) '(x a x z)) => '(a x a)) +(check (lset-intersection! eq? '(a x y a) '(x a x z)) => '(a x a)) +(check (lset-intersection eq? '(a b c)) => '(a b c)) +(check (lset-intersection! eq? '(a b c)) => '(a b c)) + +(check (lset-difference eq? '(a b c d e) '(a e i o u)) => '(b c d)) +(check (lset-difference! eq? '(a b c d e) '(a e i o u)) => '(b c d)) +(check (lset-difference eq? '(a b c)) => '(a b c)) +(check (lset-difference! eq? '(a b c)) => '(a b c)) + +(check (lset-xor eq? '(a b c d e) '(a e i o u)) => '(u o i b c d)) +(check (lset-xor! eq? '(a b c d e) '(a e i o u)) => '(u o i b c d)) +(check (lset-xor eq?) => '()) +(check (lset-xor! eq?) => '()) +(check (lset-xor eq? '(a b c d e)) => '(a b c d e)) +(check (lset-xor! eq? '(a b c d e)) => '(a b c d e)) + +(call-with-values (lambda () (lset-diff+intersection eq? '(a b c d e) '(a e i o u))) (lambda (x y) (check x => '(b c d)) (check y => '(a e)))) +(call-with-values (lambda () (lset-diff+intersection! eq? '(a b c d e) '(a e i o u))) (lambda (x y) (check x => '(b c d)) (check y => '(a e)))) + +(check-report) + +(exit (check-passed? 408))