From 0c27921f519c6620ad5ffa0dc05042560fd12d38 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 15 Jan 2018 23:51:16 +0900 Subject: [PATCH] adding (srfi 101) --- AUTHORS | 3 + COPYING | 2 +- doc/chibi.scrbl | 2 + lib/srfi/101.scm | 459 ++++++++++++++++++++++++++++++++++++++++++ lib/srfi/101.sld | 59 ++++++ lib/srfi/101/test.sld | 143 +++++++++++++ tests/lib-tests.scm | 4 + 7 files changed, 671 insertions(+), 1 deletion(-) create mode 100644 lib/srfi/101.scm create mode 100644 lib/srfi/101.sld create mode 100644 lib/srfi/101/test.sld diff --git a/AUTHORS b/AUTHORS index 1b603f68..3daaec91 100644 --- a/AUTHORS +++ b/AUTHORS @@ -14,6 +14,9 @@ The (scheme time) module includes code for handling leap seconds from Alan Watson's Scheme clock library at http://code.google.com/p/scheme-clock/ under the same license. +The (srfi 101) library is adapted from the reference implementation +by David van Horn. + The benchmarks are based on the Racket versions of the classic Gabriel benchmarks from http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html. diff --git a/COPYING b/COPYING index efa6e6cd..7bc7ea2c 100644 --- a/COPYING +++ b/COPYING @@ -1,4 +1,4 @@ -Copyright (c) 2009-2015 Alex Shinn +Copyright (c) 2009-2018 Alex Shinn All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index 9ee4aad2..688ec807 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -1195,6 +1195,7 @@ snow-fort): \item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}} \item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}} \item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}} +\item{\hyperlink["http://srfi.schemers.org/srfi-101/srfi-101.html"]{(srfi 101) - purely functional random-access pairs and lists}} \item{\hyperlink["http://srfi.schemers.org/srfi-111/srfi-111.html"]{(srfi 111) - boxes}} \item{\hyperlink["http://srfi.schemers.org/srfi-113/srfi-113.html"]{(srfi 113) - sets and bags}} \item{\hyperlink["http://srfi.schemers.org/srfi-115/srfi-115.html"]{(srfi 115) - Scheme regular expressions}} @@ -1203,6 +1204,7 @@ snow-fort): \item{\hyperlink["http://srfi.schemers.org/srfi-121/srfi-121.html"]{(srfi 121) - generators}} \item{\hyperlink["http://srfi.schemers.org/srfi-124/srfi-124.html"]{(srfi 124) - ephemerons}} \item{\hyperlink["http://srfi.schemers.org/srfi-125/srfi-125.html"]{(srfi 125) - intermediate hash tables}} +\item{\hyperlink["http://srfi.schemers.org/srfi-127/srfi-127.html"]{(srfi 127) - lazy sequences}} \item{\hyperlink["http://srfi.schemers.org/srfi-128/srfi-128.html"]{(srfi 128) - comparators (reduced)}} \item{\hyperlink["http://srfi.schemers.org/srfi-129/srfi-129.html"]{(srfi 129) - titlecase procedures}} \item{\hyperlink["http://srfi.schemers.org/srfi-130/srfi-130.html"]{(srfi 130) - cursor-based string library}} diff --git a/lib/srfi/101.scm b/lib/srfi/101.scm new file mode 100644 index 00000000..34740387 --- /dev/null +++ b/lib/srfi/101.scm @@ -0,0 +1,459 @@ +;; Adapted for R7RS by Alex Shinn 2018. + +;; SRFI 101: Purely Functional Random-Access Pairs and Lists +;; Copyright (c) David Van Horn 2009. All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without restriction, +;; including without limitation the rights to use, copy, modify, merge, +;; publish, distribute, sublicense, and/or sell copies of the Software, +;; and to permit persons to whom the Software is furnished to do so, +;; subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. REMEMBER, THERE IS NO SCHEME UNDERGROUND. IN NO EVENT +;; SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, +;; DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR +;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR +;; THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +(define-record-type kons + (make-kons size tree rest) + kons? + (size kons-size) + (tree kons-tree) + (rest kons-rest)) + +(define-record-type node + (make-node val left right) + node? + (val node-val) + (left node-left) + (right node-right)) + +(define-syntax assert + (syntax-rules () + ((assert expr ...) + (begin (unless expr (error "assertion failed" 'expr)) ...)))) + +;; Nat -> Nat +(define (sub1 n) (- n 1)) +(define (add1 n) (+ n 1)) + +;; [Tree X] -> X +(define (tree-val t) + (if (node? t) + (node-val t) + t)) + +;; [X -> Y] [Tree X] -> [Tree Y] +(define (tree-map f t) + (if (node? t) + (make-node (f (node-val t)) + (tree-map f (node-left t)) + (tree-map f (node-right t))) + (f t))) + +;; [X -> Y] [Tree X] -> unspecified +(define (tree-for-each f t) + (if (node? t) + (begin (f (node-val t)) + (tree-for-each f (node-left t)) + (tree-for-each f (node-right t))) + (f t))) + +;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> [Tree R] +(define (tree-map/n f ts) + (let recr ((ts ts)) + (if (and (pair? ts) + (node? (car ts))) + (make-node (apply f (map node-val ts)) + (recr (map node-left ts)) + (recr (map node-right ts))) + (apply f ts)))) + +;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> unspecified +(define (tree-for-each/n f ts) + (let recr ((ts ts)) + (if (and (pair? ts) + (node? (car ts))) + (begin (apply f (map node-val ts)) + (recr (map node-left ts)) + (recr (map node-right ts))) + (apply f ts)))) + +;; Nat [Nat -> X] -> [Tree X] +;; like build-list, but for complete binary trees +(define (build-tree i f) ;; i = 2^j-1 + (let rec ((i i) (o 0)) + (if (= 1 i) + (f o) + (let ((i/2 (half i))) + (make-node (f o) + (rec i/2 (add1 o)) + (rec i/2 (+ 1 o i/2))))))) + +;; Consumes n = 2^i-1 and produces 2^(i-1)-1. +;; Nat -> Nat +(define (half n) + (bitwise-arithmetic-shift n -1)) + +;; Nat X -> [Tree X] +(define (tr:make-tree i x) ;; i = 2^j-1 + (let recr ((i i)) + (if (= 1 i) + x + (let ((n (recr (half i)))) + (make-node x n n))))) + +;; Nat [Tree X] Nat [X -> X] -> X [Tree X] +(define (tree-ref/update mid t i f) + (cond ((zero? i) + (if (node? t) + (values (node-val t) + (make-node (f (node-val t)) + (node-left t) + (node-right t))) + (values t (f t)))) + ((<= i mid) + (let-values (((v* t*) (tree-ref/update (half (sub1 mid)) + (node-left t) + (sub1 i) + f))) + (values v* (make-node (node-val t) t* (node-right t))))) + (else + (let-values (((v* t*) (tree-ref/update (half (sub1 mid)) + (node-right t) + (sub1 (- i mid)) + f))) + (values v* (make-node (node-val t) (node-left t) t*)))))) + +;; Special-cased above to avoid logarathmic amount of cons'ing +;; and any multi-values overhead. Operates in constant space. +;; [Tree X] Nat Nat -> X +;; invariant: (= mid (half (sub1 (tree-count t)))) +(define (tree-ref/a t i mid) + (cond ((zero? i) (tree-val t)) + ((<= i mid) + (tree-ref/a (node-left t) + (sub1 i) + (half (sub1 mid)))) + (else + (tree-ref/a (node-right t) + (sub1 (- i mid)) + (half (sub1 mid)))))) + +;; Nat [Tree X] Nat -> X +;; invariant: (= size (tree-count t)) +(define (tree-ref size t i) + (if (zero? i) + (tree-val t) + (tree-ref/a t i (half (sub1 size))))) + +;; Nat [Tree X] Nat [X -> X] -> [Tree X] +(define (tree-update size t i f) + (let recr ((mid (half (sub1 size))) (t t) (i i)) + (cond ((zero? i) + (if (node? t) + (make-node (f (node-val t)) + (node-left t) + (node-right t)) + (f t))) + ((<= i mid) + (make-node (node-val t) + (recr (half (sub1 mid)) + (node-left t) + (sub1 i)) + (node-right t))) + (else + (make-node (node-val t) + (node-left t) + (recr (half (sub1 mid)) + (node-right t) + (sub1 (- i mid)))))))) + +;; ------------------------ +;; Random access lists + +;; [RaListof X] +(define ra:null (quote ())) + +;; [Any -> Boolean] +(define ra:pair? kons?) + +;; [Any -> Boolean] +(define ra:null? null?) + +;; X [RaListof X] -> [RaListof X] /\ +;; X Y -> [RaPair X Y] +(define (ra:cons x ls) + (if (kons? ls) + (let ((s (kons-size ls))) + (if (and (kons? (kons-rest ls)) + (= (kons-size (kons-rest ls)) + s)) + (make-kons (+ 1 s s) + (make-node x + (kons-tree ls) + (kons-tree (kons-rest ls))) + (kons-rest (kons-rest ls))) + (make-kons 1 x ls))) + (make-kons 1 x ls))) + + +;; [RaPair X Y] -> X Y +(define ra:car+cdr + (lambda (p) + (assert (kons? p)) + (if (node? (kons-tree p)) + (let ((s* (half (kons-size p)))) + (values (tree-val (kons-tree p)) + (make-kons s* + (node-left (kons-tree p)) + (make-kons s* + (node-right (kons-tree p)) + (kons-rest p))))) + (values (kons-tree p) (kons-rest p))))) + +;; [RaPair X Y] -> X +(define (ra:car p) + (call-with-values (lambda () (ra:car+cdr p)) + (lambda (car cdr) car))) + +;; [RaPair X Y] -> Y +(define (ra:cdr p) + (call-with-values (lambda () (ra:car+cdr p)) + (lambda (car cdr) cdr))) + +;; [RaListof X] Nat [X -> X] -> X [RaListof X] +(define (ra:list-ref/update ls i f) + ;(assert (< i (ra:length ls))) + (let recr ((xs ls) (j i)) + (if (< j (kons-size xs)) + (let-values (((v* t*) + (tree-ref/update (half (sub1 (kons-size xs))) + (kons-tree xs) j f))) + (values v* (make-kons (kons-size xs) + t* + (kons-rest xs)))) + (let-values (((v* r*) + (recr (kons-rest xs) + (- j (kons-size xs))))) + (values v* (make-kons (kons-size xs) + (kons-tree xs) + r*)))))) + +;; [RaListof X] Nat [X -> X] -> [RaListof X] +(define (ra:list-update ls i f) + ;(assert (< i (ra:length ls))) + (let recr ((xs ls) (j i)) + (let ((s (kons-size xs))) + (if (< j s) + (make-kons s (tree-update s (kons-tree xs) j f) (kons-rest xs)) + (make-kons s (kons-tree xs) (recr (kons-rest xs) (- j s))))))) + +;; [RaListof X] Nat X -> (values X [RaListof X]) +(define (ra:list-ref/set ls i v) + (ra:list-ref/update ls i (lambda (_) v))) + +;; X ... -> [RaListof X] +(define (ra:list . xs) + (fold-right ra:cons ra:null xs)) + +;; Nat X -> [RaListof X] +(define ra:make-list + (case-lambda + ((k) (ra:make-list k 0)) + ((k obj) + (let loop ((n k) (a ra:null)) + (cond ((zero? n) a) + (else + (let ((t (largest-skew-binary n))) + (loop (- n t) + (make-kons t (tr:make-tree t obj) a))))))))) + +;; A Skew is a Nat 2^k-1 with k > 0. + +;; Skew -> Skew +(define (skew-succ t) (add1 (bitwise-arithmetic-shift t 1))) + +;; Computes the largest skew binary term t <= n. +;; Nat -> Skew +(define (largest-skew-binary n) + (if (= 1 n) + 1 + (let* ((t (largest-skew-binary (half n))) + (s (skew-succ t))) + (if (> s n) t s)))) + +;; [Any -> Boolean] +;; Is x a PROPER list? +(define (ra:list? x) + (or (ra:null? x) + (and (kons? x) + (ra:list? (kons-rest x))))) + +(define ra:caar (lambda (ls) (ra:car (ra:car ls)))) +(define ra:cadr (lambda (ls) (ra:car (ra:cdr ls)))) +(define ra:cddr (lambda (ls) (ra:cdr (ra:cdr ls)))) +(define ra:cdar (lambda (ls) (ra:cdr (ra:car ls)))) + +(define ra:caaar (lambda (ls) (ra:car (ra:car (ra:car ls))))) +(define ra:caadr (lambda (ls) (ra:car (ra:car (ra:cdr ls))))) +(define ra:caddr (lambda (ls) (ra:car (ra:cdr (ra:cdr ls))))) +(define ra:cadar (lambda (ls) (ra:car (ra:cdr (ra:car ls))))) +(define ra:cdaar (lambda (ls) (ra:cdr (ra:car (ra:car ls))))) +(define ra:cdadr (lambda (ls) (ra:cdr (ra:car (ra:cdr ls))))) +(define ra:cdddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr ls))))) +(define ra:cddar (lambda (ls) (ra:cdr (ra:cdr (ra:car ls))))) + +(define ra:caaaar (lambda (ls) (ra:car (ra:car (ra:car (ra:car ls)))))) +(define ra:caaadr (lambda (ls) (ra:car (ra:car (ra:car (ra:cdr ls)))))) +(define ra:caaddr (lambda (ls) (ra:car (ra:car (ra:cdr (ra:cdr ls)))))) +(define ra:caadar (lambda (ls) (ra:car (ra:car (ra:cdr (ra:car ls)))))) +(define ra:cadaar (lambda (ls) (ra:car (ra:cdr (ra:car (ra:car ls)))))) +(define ra:cadadr (lambda (ls) (ra:car (ra:cdr (ra:car (ra:cdr ls)))))) +(define ra:cadddr (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:cdr ls)))))) +(define ra:caddar (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:car ls)))))) +(define ra:cdaaar (lambda (ls) (ra:cdr (ra:car (ra:car (ra:car ls)))))) +(define ra:cdaadr (lambda (ls) (ra:cdr (ra:car (ra:car (ra:cdr ls)))))) +(define ra:cdaddr (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:cdr ls)))))) +(define ra:cdadar (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:car ls)))))) +(define ra:cddaar (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:car ls)))))) +(define ra:cddadr (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:cdr ls)))))) +(define ra:cddddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:cdr ls)))))) +(define ra:cdddar (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:car ls)))))) + +;; [RaList X] -> Nat +(define (ra:length ls) + (assert (ra:list? ls)) + (let recr ((ls ls)) + (if (kons? ls) + (+ (kons-size ls) (recr (kons-rest ls))) + 0))) + +(define (make-foldl empty? first rest) + (letrec ((f (lambda (cons empty ls) + (if (empty? ls) + empty + (f cons + (cons (first ls) empty) + (rest ls)))))) + f)) + +(define (make-foldr empty? first rest) + (letrec ((f (lambda (cons empty ls) + (if (empty? ls) + empty + (cons (first ls) + (f cons empty (rest ls))))))) + f)) + +;; [X Y -> Y] Y [RaListof X] -> Y +(define ra:foldl/1 (make-foldl ra:null? ra:car ra:cdr)) +(define ra:foldr/1 (make-foldr ra:null? ra:car ra:cdr)) + +;; [RaListof X] ... -> [RaListof X] +(define (ra:append . lss) + (cond ((null? lss) ra:null) + (else (let recr ((lss lss)) + (cond ((null? (cdr lss)) (car lss)) + (else (ra:foldr/1 ra:cons + (recr (cdr lss)) + (car lss)))))))) + +;; [RaListof X] -> [RaListof X] +(define (ra:reverse ls) + (ra:foldl/1 ra:cons ra:null ls)) + +;; [RaListof X] Nat -> [RaListof X] +(define (ra:list-tail ls i) + (let loop ((xs ls) (j i)) + (cond ((zero? j) xs) + (else (loop (ra:cdr xs) (sub1 j)))))) + +;; [RaListof X] Nat -> X +;; Special-cased above to avoid logarathmic amount of cons'ing +;; and any multi-values overhead. Operates in constant space. +(define (ra:list-ref ls i) + ;(assert (< i (ra:length ls))) + (let loop ((xs ls) (j i)) + (if (< j (kons-size xs)) + (tree-ref (kons-size xs) (kons-tree xs) j) + (loop (kons-rest xs) (- j (kons-size xs)))))) + +;; [RaListof X] Nat X -> [RaListof X] +(define (ra:list-set ls i v) + (let-values (((_ l*) (ra:list-ref/set ls i v))) l*)) + +;; [X ... -> y] [RaListof X] ... -> [RaListof Y] +;; Takes advantage of the fact that map produces a list of equal size. +(define ra:map + (case-lambda + ((f ls) + (let recr ((ls ls)) + (if (kons? ls) + (make-kons (kons-size ls) + (tree-map f (kons-tree ls)) + (recr (kons-rest ls))) + ra:null))) + ((f . lss) + ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss) + (let recr ((lss lss)) + (cond ((ra:null? (car lss)) ra:null) + (else + ;; IMPROVE ME: make one pass over lss. + (make-kons (kons-size (car lss)) + (tree-map/n f (map kons-tree lss)) + (recr (map kons-rest lss))))))))) + + +;; [X ... -> Y] [RaListof X] ... -> unspecified +(define ra:for-each + (case-lambda + ((f ls) + (when (kons? ls) + (tree-for-each f (kons-tree ls)) + (ra:for-each f (kons-rest ls)))) + ((f . lss) + ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss) + (let recr ((lss lss)) + (when (ra:pair? (car lss)) + (tree-map/n f (map kons-tree lss)) + (recr (map kons-rest lss))))))) + +;; [RaListof X] -> [Listof X] +(define (ra:random-access-list->linear-access-list x) + (ra:foldr/1 cons '() x)) + +;; [Listof X] -> [RaListof X] +(define (ra:linear-access-list->random-access-list x) + (fold-right ra:cons '() x)) + +;; This code based on code written by Abdulaziz Ghuloum +;; http://ikarus-scheme.org/pipermail/ikarus-users/2009-September/000595.html +(define get-cached + (let ((h (make-hash-table eq?))) + (lambda (x) + (define (f x) + (cond + ((pair? x) (ra:cons (f (car x)) (f (cdr x)))) + ((vector? x) (vector-map f x)) + (else x))) + (cond + ((not (or (pair? x) (vector? x))) x) + ((hash-table-ref/default h x #f)) + (else + (let ((v (f x))) + (hash-table-set! h x v) + v)))))) + +(define-syntax ra:quote + (syntax-rules () + ((ra:quote datum) (get-cached 'datum)))) diff --git a/lib/srfi/101.sld b/lib/srfi/101.sld new file mode 100644 index 00000000..daef1b8a --- /dev/null +++ b/lib/srfi/101.sld @@ -0,0 +1,59 @@ + +(define-library (srfi 101) + (import (scheme base) + (scheme case-lambda) + (srfi 1) + (srfi 125) + (rename (srfi 151) + (arithmetic-shift bitwise-arithmetic-shift))) + (export (rename ra:quote quote) + (rename ra:pair? pair?) + (rename ra:cons cons) + (rename ra:car car) + (rename ra:cdr cdr) + (rename ra:caar caar) + (rename ra:cadr cadr) + (rename ra:cddr cddr) + (rename ra:cdar cdar) + (rename ra:caaar caaar) + (rename ra:caadr caadr) + (rename ra:caddr caddr) + (rename ra:cadar cadar) + (rename ra:cdaar cdaar) + (rename ra:cdadr cdadr) + (rename ra:cdddr cdddr) + (rename ra:cddar cddar) + (rename ra:caaaar caaaar) + (rename ra:caaadr caaadr) + (rename ra:caaddr caaddr) + (rename ra:caadar caadar) + (rename ra:cadaar cadaar) + (rename ra:cadadr cadadr) + (rename ra:cadddr cadddr) + (rename ra:caddar caddar) + (rename ra:cdaaar cdaaar) + (rename ra:cdaadr cdaadr) + (rename ra:cdaddr cdaddr) + (rename ra:cdadar cdadar) + (rename ra:cddaar cddaar) + (rename ra:cddadr cddadr) + (rename ra:cddddr cddddr) + (rename ra:cdddar cdddar) + (rename ra:null? null?) + (rename ra:list? list?) + (rename ra:list list) + (rename ra:make-list make-list) + (rename ra:length length) + (rename ra:append append) + (rename ra:reverse reverse) + (rename ra:list-tail list-tail) + (rename ra:list-ref list-ref) + (rename ra:list-set list-set) + (rename ra:list-ref/update list-ref/update) + (rename ra:map map) + (rename ra:for-each for-each) + (rename ra:random-access-list->linear-access-list + random-access-list->linear-access-list) + (rename ra:linear-access-list->random-access-list + linear-access-list->random-access-list)) + (include "101.scm")) diff --git a/lib/srfi/101/test.sld b/lib/srfi/101/test.sld new file mode 100644 index 00000000..c96af0b6 --- /dev/null +++ b/lib/srfi/101/test.sld @@ -0,0 +1,143 @@ + +;; Adapted from the reference implementation test suite for R7RS. + +(define-library (srfi 101 test) + (import (except (scheme base) + quote pair? cons car cdr + caar cadr cddr cdar + null? list? list make-list length + append reverse list-tail + list-ref map for-each) + (prefix (scheme base) r7:) + (srfi 101) + (chibi test)) + (export run-tests) + (begin + (define (run-tests) + + (test-begin "srfi-101: random access lists") + + (test-assert (let ((f (lambda () '(x)))) + (eq? (f) (f)))) + + (test '(1 2 3) (list 1 2 3)) + + ;; pair? + (test-assert (pair? (cons 'a 'b))) + (test-assert (pair? (list 'a 'b 'c))) + (test-not (pair? '())) + (test-not (pair? '#(a b))) + + ;; cons + (test (cons 'a '()) (list 'a)) + (test (cons (list 'a) (list 'b 'c 'd)) + (list (list 'a) 'b 'c 'd)) + (test (cons "a" (list 'b 'c)) + (list "a" 'b 'c)) + (test (cons 'a 3) + (cons 'a 3)) + (test (cons (list 'a 'b) 'c) + (cons (list 'a 'b) 'c)) + + ;; car + (test 'a + (car (list 'a 'b 'c))) + (test (list 'a) + (car (list (list 'a) 'b 'c 'd))) + (test 1 (car (cons 1 1))) + (test-error (car '())) + + ;; cdr + (test (list 'b 'c 'd) + (cdr (list (list 'a) 'b 'c 'd))) + (test 2 + (cdr (cons 1 2))) + (test-error (cdr '())) + + ;; null? + (test-assert (eq? null? r7:null?)) + (test-assert (null? '())) + (test-not (null? (cons 1 2))) + (test-not (null? 4)) + + ;; list? + (test-assert (list? (list 'a 'b 'c))) + (test-assert (list? '())) + (test-not (list? (cons 'a 'b))) + + ;; list + (test (list 'a 7 'c) + (list 'a (+ 3 4) 'c)) + (test '() (list)) + + ;; make-list + (test 5 (length (make-list 5))) + (test (list 0 0 0 0 0) + (make-list 5 0)) + + ;; length + (test 3 (length (list 'a 'b 'c))) + (test 3 (length (list 'a (list 'b) (list 'c)))) + (test 0 (length '())) + + ;; append + (test (list 'x 'y) (append (list 'x) (list 'y))) + (test (list 'a 'b 'c 'd) (append (list 'a) (list 'b 'c 'd))) + (test (list 'a (list 'b) (list 'c)) + (append (list 'a (list 'b)) (list (list 'c)))) + (test (cons 'a (cons 'b (cons 'c 'd))) + (append (list 'a 'b) (cons 'c 'd))) + (test 'a (append '() 'a)) + + ;; reverse + (test (list 'c 'b 'a) + (reverse (list 'a 'b 'c))) + (test (list (list 'e (list 'f)) 'd (list 'b 'c) 'a) + (reverse (list 'a (list 'b 'c) 'd (list 'e (list 'f))))) + + ;; list-tail + (test (list 'c 'd) + (list-tail (list 'a 'b 'c 'd) 2)) + + ;; list-ref + (test 'c (list-ref (list 'a 'b 'c 'd) 2)) + + ;; list-set + (test (list 'a 'b 'x 'd) + (list-set (list 'a 'b 'c 'd) 2 'x)) + + ;; list-ref/update + (let-values (((a b) + (list-ref/update (list 7 8 9 10) 2 -))) + (test 9 a) + (test (list 7 8 -9 10) (values b))) + + ;; map + (test (list 'b 'e 'h) + (map cadr (list (list 'a 'b) (list 'd 'e) (list 'g 'h)))) + (test (list 1 4 27 256 3125) + (map (lambda (n) (expt n n)) + (list 1 2 3 4 5))) + (test (list 5 7 9) + (map + (list 1 2 3) (list 4 5 6))) + + ;; for-each + (test '#(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each (lambda (i) + (vector-set! v i (* i i))) + (list 0 1 2 3 4)) + v)) + + ;; random-access-list->linear-access-list + ;; linear-access-list->random-access-list + (test '() (random-access-list->linear-access-list '())) + (test '() (linear-access-list->random-access-list '())) + + (test (r7:list 1 2 3) + (random-access-list->linear-access-list (list 1 2 3))) + + (test (list 1 2 3) + (linear-access-list->random-access-list (r7:list 1 2 3))) + + (test-end)))) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 111bb4c3..206d3294 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -13,9 +13,11 @@ (rename (srfi 69 test) (run-tests run-srfi-69-tests)) (rename (srfi 95 test) (run-tests run-srfi-95-tests)) (rename (srfi 99 test) (run-tests run-srfi-99-tests)) + (rename (srfi 101 test) (run-tests run-srfi-101-tests)) (rename (srfi 116 test) (run-tests run-srfi-116-tests)) (rename (srfi 117 test) (run-tests run-srfi-117-tests)) (rename (srfi 121 test) (run-tests run-srfi-121-tests)) + (rename (srfi 125 test) (run-tests run-srfi-125-tests)) (rename (srfi 127 test) (run-tests run-srfi-127-tests)) (rename (srfi 128 test) (run-tests run-srfi-128-tests)) (rename (srfi 129 test) (run-tests run-srfi-129-tests)) @@ -68,9 +70,11 @@ (run-srfi-69-tests) (run-srfi-95-tests) (run-srfi-99-tests) +(run-srfi-101-tests) (run-srfi-116-tests) (run-srfi-117-tests) (run-srfi-121-tests) +(run-srfi-125-tests) (run-srfi-127-tests) (run-srfi-128-tests) (run-srfi-129-tests)