From 050b7050e38dec3b8301356053582505f6677afc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <address@hidden>
Date: Fri, 11 Jan 2019 19:41:20 -0200
Subject: [PATCH 07/10] Implemented SRFI-128

---
 module/Makefile.am             |   2 +
 module/srfi/srfi-128.scm       | 577 +++++++++++++++++++++++++++++++++
 module/srfi/srfi-128/gnu.scm   |  38 +++
 test-suite/Makefile.am         |   1 +
 test-suite/tests/srfi-128.test | 348 ++++++++++++++++++++
 5 files changed, 966 insertions(+)
 create mode 100644 module/srfi/srfi-128.scm
 create mode 100644 module/srfi/srfi-128/gnu.scm
 create mode 100644 test-suite/tests/srfi-128.test

diff --git a/module/Makefile.am b/module/Makefile.am
index 6e739fed0..5fc3010c1 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -295,6 +295,8 @@ SOURCES =					\
   srfi/srfi-98.scm				\
   srfi/srfi-111.scm				\
   srfi/srfi-126.scm				\
+  srfi/srfi-128/gnu.scm				\
+  srfi/srfi-128.scm				\
 						\
   statprof.scm					\
 						\
diff --git a/module/srfi/srfi-128.scm b/module/srfi/srfi-128.scm
new file mode 100644
index 000000000..bdacfb3c0
--- /dev/null
+++ b/module/srfi/srfi-128.scm
@@ -0,0 +1,577 @@
+;;; srfi-128.scm --- Comparators
+
+;;    Copyright (C) 2019 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;; This file contains code from SRFI 128 reference implementation, by
+;; John Cowan
+
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+
+(define-module (srfi srfi-128)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-43)
+  ;; HASH-BOUND, HASH-SALT and WITH-HASH-SALT are defined here because
+  ;; the latter is not standard
+  #:use-module ((srfi srfi-128 gnu) #:select (hash-bound hash-salt))
+  #:use-module ((rnrs unicode) #:select (char-foldcase))
+  #:use-module (rnrs bytevectors)
+  #:use-module ((ice-9 generic-hash-tables)
+                #:select ((hash . equal-hash)
+                          string-ci-hash hash-by-identity hash-by-value))
+  #:export (comparator?
+            make-comparator
+            comparator-type-test-predicate comparator-equality-predicate
+            comparator-ordering-predicate comparator-hash-function
+            comparator-ordered? comparator-hashable?
+            comparator-test-type comparator-check-type
+            comparator-hash
+            make-pair-comparator make-list-comparator make-vector-comparator
+            make-eq-comparator make-eqv-comparator make-equal-comparator
+            boolean-hash char-hash char-ci-hash number-hash
+            make-default-comparator default-hash
+            comparator-register-default!
+            =? <? >? <=? >=?
+            comparator-if<=>)
+  #:re-export (string-hash string-ci-hash symbol-hash hash-bound hash-salt))
+
+(cond-expand-provide (current-module) '(srfi-128))
+
+
+;; Arithmetic if
+(define-syntax comparator-if<=>
+  (syntax-rules ()
+    ((if<=> a b less equal greater)
+     (comparator-if<=> default-comparator a b less equal greater))
+    ((comparator-if<=> comparator a b less equal greater)
+     (cond
+      ((<? comparator a b) less)
+      ((=? comparator a b) equal)
+      (else greater)))))
+
+
+;;; Definition of comparator records with accessors and basic comparator
+
+(define-record-type comparator
+  (make-raw-comparator type-test equality ordering hash ordering? hash?)
+  comparator?
+  (type-test comparator-type-test-predicate)
+  (equality comparator-equality-predicate)
+  (ordering comparator-ordering-predicate)
+  (hash comparator-hash-function)
+  (ordering? comparator-ordered?)
+  (hash? comparator-hashable?))
+
+(define (always-true obj) #t)
+
+;; Public constructor
+(define (make-comparator type-test equality ordering hash)
+  (make-raw-comparator
+   (if (eq? type-test #t) always-true type-test)
+   (if (eq? equality #t) (lambda (x y) (eqv? (ordering x y) 0)) equality)
+   (if ordering ordering (lambda (x y) (error "ordering not supported")))
+   (if hash hash (lambda (x y) (error "hashing not supported")))
+   (if ordering #t #f)
+   (if hash #t #f)))
+
+
+;;; Invokers
+
+;; Invoke the test type
+(define (comparator-test-type comparator obj)
+  ((comparator-type-test-predicate comparator) obj))
+
+;; Invoke the test type and throw an error if it fails
+(define (comparator-check-type comparator obj)
+  (if (comparator-test-type comparator obj)
+      #t
+      (error "Comparator type check failed" comparator obj)))
+
+;; Invoke the hash function
+(define (comparator-hash comparator obj)
+  ((comparator-hash-function comparator) obj))
+
+
+;;; Comparison predicates
+
+;; Binary versions for internal use
+
+(define (binary=? comparator a b)
+  ((comparator-equality-predicate comparator) a b))
+
+(define (binary<? comparator a b)
+  ((comparator-ordering-predicate comparator) a b))
+
+(define (binary>? comparator a b)
+  (binary<? comparator b a))
+
+(define (binary<=? comparator a b)
+  (not (binary>? comparator a b)))
+
+(define (binary>=? comparator a b)
+  (not (binary<? comparator a b)))
+
+;; General versions for export
+
+(define (=? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary=? comparator a b)
+	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary<? comparator a b)
+	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary>? comparator a b)
+	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<=? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary<=? comparator a b)
+	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>=? comparator a b . objs)
+  (let loop ((a a) (b b) (objs objs))
+    (and (binary>=? comparator a b)
+	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+
+;;; Simple ordering and hash functions
+
+(define boolean-hash hash-by-identity)
+(define char-hash    hash-by-identity)
+(define number-hash  hash-by-value)
+
+(define* (char-ci-hash c #:optional (size most-positive-fixnum))
+  (hashq (char-foldcase c) size))
+
+;; Lexicographic ordering of complex numbers
+(define (complex<? a b)
+  (or (< (real-part a) (real-part b))
+      (and (= (real-part a) (real-part b))
+           (< (imag-part a) (imag-part b)))))
+
+(define (symbol<? a b)
+  ;; Valid according to spec.
+  ;; It's faster to hash than to compare strings.
+  (let ((ha (hashq a (hash-bound)))
+        (hb (hashq b (hash-bound))))
+    (or (< ha hb)
+        (and (= ha hb)
+             (not (eq? a b))
+             (string<? (symbol->string a) (symbol->string b))))))
+
+;; Stick to fixnums
+(define lower-mask (ash (hash-bound) -5)) ; (/ (hash-bound) 32)
+
+;; Hash helper
+(define (mix h1 h2)
+  (logxor (* (logand h1 lower-mask) 31) h2))
+
+
+
+;;; Pair comparator
+(define (make-pair-comparator car-comparator cdr-comparator)
+  (make-comparator
+   (make-pair-type-test car-comparator cdr-comparator)
+   (make-pair=? car-comparator cdr-comparator)
+   (make-pair<? car-comparator cdr-comparator)
+   (make-pair-hash car-comparator cdr-comparator)))
+
+(define (make-pair-type-test car-comparator cdr-comparator)
+  (let ((car-test (comparator-type-test-predicate car-comparator))
+        (cdr-test (comparator-type-test-predicate cdr-comparator)))
+    (if (eq? always-true car-test cdr-test)
+        pair?
+        (lambda (obj)
+          (and (pair? obj)
+               (car-test (car obj))
+               (cdr-test (cdr obj)))))))
+
+(define (make-pair=? car-comparator cdr-comparator)
+  (let ((car-equiv (comparator-equality-predicate car-comparator))
+        (cdr-equiv (comparator-equality-predicate cdr-comparator)))
+    (if (eq? equal? car-equiv cdr-equiv)
+        equal?
+        (lambda (a b)
+          (and (car-equiv (car a) (car b))
+               (cdr-equiv (cdr a) (cdr b)))))))
+
+(define (make-pair<? car-comparator cdr-comparator)
+  (let ((car-equiv (comparator-equality-predicate car-comparator))
+        (car<? (comparator-ordering-predicate car-comparator))
+        (cdr<? (comparator-ordering-predicate cdr-comparator)))
+    (lambda (a b)
+      (or (car<? (car a) (car b))
+          (and (car-equiv (car a) (car b))
+               (cdr<? (cdr a) (cdr b)))))))
+
+(define pair-hash-salt (mix (symbol-hash 'pair) (hash-salt)))
+
+(define (make-pair-hash car-comparator cdr-comparator)
+  (let ((car-hash (comparator-hash-function car-comparator))
+        (cdr-hash (comparator-hash-function cdr-comparator)))
+    (if (eq? equal-hash car-hash cdr-hash)
+        equal-hash
+        (lambda (obj)
+          (mix (mix pair-hash-salt (car-hash (car obj)))
+               (cdr-hash (cdr obj)))))))
+
+
+;;; List comparator
+
+(define (make-list-comparator element-comparator type-test empty? head tail)
+  (make-comparator
+   (make-list-type-test element-comparator type-test empty? head tail)
+   (make-list=? element-comparator type-test empty? head tail)
+   (make-list<? element-comparator type-test empty? head tail)
+   (make-list-hash element-comparator type-test empty? head tail)))
+
+(define (make-list-type-test element-comparator type-test empty? head tail)
+  (let ((elem-type-test (comparator-type-test-predicate element-comparator)))
+    (lambda (obj)
+      (and
+       (type-test obj)
+       (let loop ((obj obj))
+         (cond
+          ((empty? obj) #t)
+          ((not (elem-type-test (head obj))) #f)
+          (else (loop (tail obj)))))))))
+
+(define (make-list=? element-comparator type-test empty? head tail)
+  (let ((elem=? (comparator-equality-predicate element-comparator)))
+    (lambda (a b)
+      (let loop ((a a) (b b))
+        (cond
+         ((empty? a) (empty? b))
+         ((empty? b) #f)
+         ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+         (else #f))))))
+
+(define (make-list<? element-comparator type-test empty? head tail)
+  (let ((elem=? (comparator-equality-predicate element-comparator))
+        (elem<? (comparator-ordering-predicate element-comparator)))
+    (lambda (a b)
+      (let loop ((a a) (b b))
+        (cond
+         ((empty? a) (not (empty? b)))
+         ((empty? b) #f)
+         ((elem<? (head a) (head b)) #t)
+         ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+         (else #f))))))
+
+(define list-hash-salt (mix (symbol-hash 'list) (hash-salt)))
+
+(define (make-list-hash element-comparator type-test empty? head tail)
+  (let ((elem-hash (comparator-hash-function element-comparator)))
+    (lambda (obj)
+      (let loop ((obj obj)
+                 (result list-hash-salt))
+        (cond
+         ((empty? obj) result)
+         (else (loop (tail obj) (mix result (elem-hash (head obj))))))))))
+
+
+;;; Vector comparator
+
+(define (make-vector-comparator element-comparator type-test length ref)
+  (make-comparator
+   (make-vector-type-test element-comparator type-test length ref)
+   (make-vector=? element-comparator type-test length ref)
+   (make-vector<? element-comparator type-test length ref)
+   (make-vector-hash element-comparator type-test length ref)))
+
+(define (make-vector-type-test element-comparator type-test length ref)
+  (let ((elem-type-test (comparator-type-test-predicate element-comparator)))
+    (lambda (obj)
+      (and
+       (type-test obj)
+       (let ((len (length obj)))
+         (let loop ((n 0))
+           (cond
+            ((= n len) #t)
+            ((not (elem-type-test (ref obj n))) #f)
+            (else (loop (+ n 1))))))))))
+
+(define (make-vector=? element-comparator type-test length ref)
+  (let ((elem=? (comparator-equality-predicate element-comparator)))
+    (lambda (a b)
+      (let ((len (length b)))
+        (and
+         (= (length a) len)
+         (let loop ((n 0))
+           (cond
+            ((= n len) #t)
+            ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+            (else #f))))))))
+
+(define (make-vector<? element-comparator type-test length ref)
+  (let ((elem=? (comparator-equality-predicate element-comparator))
+        (elem<? (comparator-ordering-predicate element-comparator)))
+    (lambda (a b)
+      (let ((lena (length a))
+            (lenb (length b)))
+        (cond
+         ((< lena lenb) #t)
+         ((> lena lenb) #f)
+         (else
+          (let loop ((n 0))
+            (cond
+             ((= n lena) #f)
+             ((elem<? (ref a n) (ref b n)) #t)
+             ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+             (else #f)))))))))
+
+(define vector-hash-salt (mix (symbol-hash 'vector) (hash-salt)))
+
+(define (make-vector-hash element-comparator type-test length ref)
+  (let ((elem-hash (comparator-hash-function element-comparator)))
+    (lambda (obj)
+      (let ((len (length obj)))
+        (let loop ((n 0) (result vector-hash-salt))
+          (cond
+           ((= n len) result)
+           (else (loop (+ n 1) (mix result (elem-hash (ref obj n)))))))))))
+
+
+;;; The default comparator
+
+;;; Standard comparators and their functions
+
+;; The unknown-object comparator, used as a fallback to everything else
+;; Everything compares exactly the same and hashes to 0
+(define unknown-object-comparator
+  (make-comparator
+   always-true
+   (lambda (a b) #t)
+   (lambda (a b) #f)
+   (lambda (obj) 0)))
+
+;; Next index for added comparator
+
+(define *next-comparator-index* 0)
+(define *registered-comparators* (make-vector 8 unknown-object-comparator))
+
+;; Register a new comparator for use by the default comparator.
+(define (comparator-register-default! comparator)
+  (let ((len (vector-length *registered-comparators*)))
+    (if (= *next-comparator-index* (- len 1))
+        (set! *registered-comparators*
+          (vector-copy *registered-comparators* 0 (* 2 len) unknown-object-comparator))))
+  (vector-set! *registered-comparators* *next-comparator-index* comparator)
+  (set! *next-comparator-index* (+ 1 *next-comparator-index*)))
+
+;; Return ordinal for object types: null sorts before booleans, which sort
+;; before numbers, etc.  Implementations can extend this.
+;; People who call comparator-register-default! effectively do extend it.
+(define (internal-object-type obj)
+  (cond
+   ((null? obj) 0)
+   ((boolean? obj) 1)
+   ((number? obj) 2)
+   ((char? obj) 3)
+   ((string? obj) 4)
+   ((symbol? obj) 5)
+   ((bytevector? obj) 6)
+   ((vector? obj) 7)
+   ((pair? obj) 8)
+   ((unspecified? obj) 9)
+   ((eof-object? obj) 10)
+   ;; Add more here if you want
+   (else #f)))
+
+(define (external-object-type obj)
+  (registered-index obj))
+
+;; Return the index for the registered type of obj.
+(define (registered-index obj)
+  (vector-index (lambda (comparator)
+                  (comparator-test-type comparator obj))
+                *registered-comparators*))
+
+(define (external-object-comparator obj)
+  (vector-any (lambda (comparator)
+                (and (comparator-test-type comparator obj)
+                     comparator))
+              *registered-comparators*))
+
+;; Given an index, retrieve a registered conductor.
+(define (registered-comparator i)
+  (vector-ref *registered-comparators* i))
+
+(define (internal-dispatch-equality type a b)
+  ;; EQUAL? already returns #t for many internal types
+  (case type
+    ;; ((0) #t) ; All empty lists are equal
+    ;; ((1) (if a (and b #t) (not b)))
+    ;; ((2) (= a b))
+    ;; ((3) (char=? a b))
+    ;; ((4) (string=? a b))
+    ;; ((5) (eq? a b))
+    ;; ((6) (default-bytevector=? a b))
+    ((7) (default-vector=? a b))
+    ((8) (default-pair=? a b))
+    ;; ((9 10) #t)
+    ;; Add more here
+    (else #f)))
+
+(define (external-dispatch-equality type a b)
+  (binary=? (registered-comparator type) a b))
+
+(define (internal-dispatch-ordering type a b)
+  ;; EQUAL? already eliminates some internal types
+  (case type
+    ;; ((0) #f) ; All empty lists are equal
+    ((1) (and (not a) b)) ; #f < #t but not otherwise
+    ((2) (complex<? a b))
+    ((3) (char<? a b))
+    ((4) (string<? a b))
+    ((5) (symbol<? a b))
+    ((6) (default-bytevector<? a b))
+    ((7) (default-vector<? a b))
+    ((8) (default-pair<? a b))
+    ;; ((9 10) #f)
+    ;; Add more here
+    ))
+
+(define (external-dispatch-ordering type a b)
+  (binary<? (registered-comparator type) a b))
+
+;; EQUAL-HASH returns the same as HASH-BY-VALUE on numbers and
+;; HASH-BY-IDENTITY on booleans, chars and symbols.
+
+(define (default-hash obj)
+  (let ((type (internal-object-type obj)))
+    (if type
+        (if (or (<= type 6) (>= type 9))
+            (equal-hash obj)
+            (case type
+              ((7) (default-vector-hash obj))
+              ((8) (default-pair-hash obj))
+              ;; Add more here
+              ))
+        (let ((comparator (external-object-comparator obj)))
+          (comparator-hash comparator obj)))))
+
+(define (default-ordering a b)
+  (and (not (equal? a b)) ; should be much faster than this procedure
+       (let ((a-itype (internal-object-type a))
+             (b-itype (internal-object-type b)))
+         (cond
+          ((not b-itype)
+           (or a-itype
+               ;; Neither a nor b are of internal type:
+               ;; dispatch ordering on external type
+               (let ((a-etype (external-object-type a))
+                     (b-etype (external-object-type b)))
+                 (cond
+                  ((< a-etype b-etype) #t)
+                  ((> a-etype b-etype) #f)
+                  (else (external-dispatch-ordering a-etype a b))))))
+          ((not a-itype) #f)
+          ;; Both a and b are of internal type
+          ((< a-itype b-itype) #t)
+          ((> a-itype b-itype) #f)
+          (else (internal-dispatch-ordering a-itype a b))))))
+
+(define (default-equality a b)
+  (or (equal? a b) ; should be much faster than this procedure
+      (let ((a-itype (internal-object-type a))
+            (b-itype (internal-object-type b)))
+        (and (eqv? a-itype b-itype)
+             (if a-itype
+                 (internal-dispatch-equality a-itype a b)
+                 (let ((a-comp (external-object-comparator a))
+                       (b-comp (external-object-comparator b)))
+                   (and (eq? a-comp b-comp) (binary=? a-comp a b))))))))
+
+;; Note: comparators are immutable, no reason to allocate a new one
+(define default-comparator (make-comparator always-true default-equality
+                                            default-ordering default-hash))
+
+(define (make-default-comparator) default-comparator)
+
+(define default-pair-comparator
+  (make-pair-comparator default-comparator default-comparator))
+
+(define default-pair=?
+  (comparator-equality-predicate default-pair-comparator))
+(define default-pair<?
+  (comparator-ordering-predicate default-pair-comparator))
+(define default-pair-hash
+  (comparator-hash-function default-pair-comparator))
+
+(define default-vector-comparator
+  (make-vector-comparator default-comparator vector?
+                          vector-length vector-ref))
+
+(define default-vector=?
+  (comparator-equality-predicate default-vector-comparator))
+(define default-vector<?
+  (comparator-ordering-predicate default-vector-comparator))
+(define default-vector-hash
+  (comparator-hash-function default-vector-comparator))
+
+(define default-bytevector-comparator
+  (make-vector-comparator default-comparator bytevector?
+                          bytevector-length bytevector-u8-ref))
+
+(define default-bytevector=?
+  (comparator-equality-predicate default-bytevector-comparator))
+(define default-bytevector<?
+  (comparator-ordering-predicate default-bytevector-comparator))
+(define default-bytevector-hash
+  (comparator-hash-function default-bytevector-comparator))
+
+;;; Wrapped equality predicates
+;;; These comparators don't have ordering functions.
+
+;; Note: comparators are immutable, no reason to allocate a new one
+(define eq-comparator (make-comparator #t eq? #f default-hash))
+(define (make-eq-comparator) eq-comparator)
+
+(define eqv-comparator (make-comparator #t eqv? #f default-hash))
+(define (make-eqv-comparator) eqv-comparator)
+
+(define equal-comparator (make-comparator #t equal? #f default-hash))
+(define (make-equal-comparator) equal-comparator)
+
+;; eof
diff --git a/module/srfi/srfi-128/gnu.scm b/module/srfi/srfi-128/gnu.scm
new file mode 100644
index 000000000..89fd434aa
--- /dev/null
+++ b/module/srfi/srfi-128/gnu.scm
@@ -0,0 +1,38 @@
+;;; Extensions to SRFI-128
+
+;;    Copyright (C) 2019 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-128 gnu)
+  #:export (hash-bound hash-salt with-hash-salt))
+
+(define-syntax hash-bound
+  (syntax-rules ()
+    ((hash-bound) most-positive-fixnum)))
+
+(define %salt% (make-parameter (random (hash-bound)
+                                       (seed->random-state (current-time)))))
+
+(define-syntax hash-salt
+  (syntax-rules ()
+    ((hash-salt) (%salt%))))
+
+(define-syntax with-hash-salt
+  (syntax-rules ()
+    ((with-hash-salt new-salt hash-func obj)
+     (parameterize ((%salt% new-salt)) (hash-func obj)))))
+
+;; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f0ad8bb91..a2f73b329 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-105.test			\
 	    tests/srfi-111.test			\
 	    tests/srfi-126.test			\
+	    tests/srfi-128.test			\
 	    tests/srfi-4.test			\
 	    tests/srfi-9.test			\
 	    tests/statprof.test			\
diff --git a/test-suite/tests/srfi-128.test b/test-suite/tests/srfi-128.test
new file mode 100644
index 000000000..02a538e22
--- /dev/null
+++ b/test-suite/tests/srfi-128.test
@@ -0,0 +1,348 @@
+;;;; srfi-128.test --- Test suite for SRFI 128 -*- scheme -*-
+;;;;
+;;;; 	Copyright (C) 2019 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; The following tests are the tests from SRFI-126 reference
+;;; implementation ported to Guile test suite.
+
+;; This file contains code from SRFI 128 reference implementation, by
+;; John Cowan
+
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+(define-module (test-srfi-128)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-128)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-8)
+  #:use-module (rnrs bytevectors))
+
+(define (vector-cdr vec)
+  (let* ((len (vector-length vec))
+         (result (make-vector (- len 1))))
+    (let loop ((n 1))
+      (cond
+       ((= n len) result)
+       (else (vector-set! result (- n 1) (vector-ref vec n))
+             (loop (+ n 1)))))))
+
+(define default-comparator (make-default-comparator))
+
+(define real-comparator (make-comparator real? = < number-hash))
+
+(define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f))
+
+(define boolean-comparator
+  (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash))
+
+(define bool-pair-comparator
+  (make-pair-comparator boolean-comparator boolean-comparator))
+
+(define num-list-comparator
+  (make-list-comparator real-comparator list? null? car cdr))
+
+(define num-vector-comparator
+  (make-vector-comparator real-comparator vector? vector-length vector-ref))
+
+(define vector-qua-list-comparator
+  (make-list-comparator
+   real-comparator
+   vector?
+   (lambda (vec) (= 0 (vector-length vec)))
+   (lambda (vec) (vector-ref vec 0))
+   vector-cdr))
+
+(define list-qua-vector-comparator
+  (make-vector-comparator default-comparator list? length list-ref))
+
+(define eq-comparator (make-eq-comparator))
+
+(define eqv-comparator (make-eqv-comparator))
+
+(define equal-comparator (make-equal-comparator))
+
+(define symbol-comparator
+  (make-comparator
+   symbol?
+   eq?
+   (lambda (a b) (string<? (symbol->string a) (symbol->string b)))
+   symbol-hash))
+
+
+(with-test-prefix "SRFI-128"
+
+  (pass-if-equal '#(2 3 4) (vector-cdr '#(1 2 3 4)))
+  (pass-if-equal '#() (vector-cdr '#(1)))
+
+  (with-test-prefix "comparators/predicates"
+    (pass-if (comparator? real-comparator))
+    (pass-if (not (comparator? =)))
+    (pass-if (comparator-ordered? real-comparator))
+    (pass-if (comparator-hashable? real-comparator))
+    (pass-if (not (comparator-ordered? degenerate-comparator)))
+    (pass-if (not (comparator-hashable? degenerate-comparator)))
+    ) ; end comparators/predicates
+
+  (with-test-prefix "comparators/constructors"
+    (pass-if (=? boolean-comparator #t #t))
+    (pass-if (not (=? boolean-comparator #t #f)))
+    (pass-if (<? boolean-comparator #f #t))
+    (pass-if (not (<? boolean-comparator #t #t)))
+    (pass-if (not (<? boolean-comparator #t #f)))
+
+    (pass-if (comparator-test-type bool-pair-comparator '(#t . #f)))
+    (pass-if (not (comparator-test-type bool-pair-comparator 32)))
+    (pass-if (not (comparator-test-type bool-pair-comparator '(32 . #f))))
+    (pass-if (not (comparator-test-type bool-pair-comparator '(#t . 32))))
+    (pass-if (not (comparator-test-type bool-pair-comparator '(32 . 34))))
+    (pass-if (=? bool-pair-comparator '(#t . #t) '(#t . #t)))
+    (pass-if (not (=? bool-pair-comparator '(#t . #t) '(#f . #t))))
+    (pass-if (not (=? bool-pair-comparator '(#t . #t) '(#t . #f))))
+    (pass-if (<? bool-pair-comparator '(#f . #t) '(#t . #t)))
+    (pass-if (<? bool-pair-comparator '(#t . #f) '(#t . #t)))
+    (pass-if (not (<? bool-pair-comparator '(#t . #t) '(#t . #t))))
+    (pass-if (not (<? bool-pair-comparator '(#t . #t) '(#f . #t))))
+    (pass-if (not (<? bool-pair-comparator '(#f . #t) '(#f . #f))))
+
+    (pass-if (comparator-test-type num-vector-comparator '#(1 2 3)))
+    (pass-if (comparator-test-type num-vector-comparator '#()))
+    (pass-if (not (comparator-test-type num-vector-comparator 1)))
+    (pass-if (not (comparator-test-type num-vector-comparator '#(a 2 3))))
+    (pass-if (not (comparator-test-type num-vector-comparator '#(1 b 3))))
+    (pass-if (not (comparator-test-type num-vector-comparator '#(1 2 c))))
+    (pass-if (=? num-vector-comparator '#(1 2 3) '#(1 2 3)))
+    (pass-if (not (=? num-vector-comparator '#(1 2 3) '#(4 5 6))))
+    (pass-if (not (=? num-vector-comparator '#(1 2 3) '#(1 5 6))))
+    (pass-if (not (=? num-vector-comparator '#(1 2 3) '#(1 2 6))))
+    (pass-if (<? num-vector-comparator '#(1 2) '#(1 2 3)))
+    (pass-if (<? num-vector-comparator '#(1 2 3) '#(2 3 4)))
+    (pass-if (<? num-vector-comparator '#(1 2 3) '#(1 3 4)))
+    (pass-if (<? num-vector-comparator '#(1 2 3) '#(1 2 4)))
+    (pass-if (<? num-vector-comparator '#(3 4) '#(1 2 3)))
+    (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(1 2 3))))
+    (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(1 2))))
+    (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(0 2 3))))
+    (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(1 1 3))))
+
+    (pass-if (not (<? vector-qua-list-comparator '#(3 4) '#(1 2 3))))
+    (pass-if (<? list-qua-vector-comparator '(3 4) '(1 2 3)))
+
+    (let ((bool-pair (cons #t #f))
+          (bool-pair-2 (cons #t #f))
+          (reverse-bool-pair (cons #f #t)))
+      (pass-if (=? eq-comparator #t #t))
+      (pass-if (not (=? eq-comparator #f #t)))
+      (pass-if (=? eqv-comparator bool-pair bool-pair))
+      (pass-if (not (=? eqv-comparator bool-pair bool-pair-2)))
+      (pass-if (=? equal-comparator bool-pair bool-pair-2))
+      (pass-if (not (=? equal-comparator bool-pair reverse-bool-pair))))
+    ) ; end comparators/constructors
+
+  (with-test-prefix "comparators/hash"
+    (pass-if (exact-integer? (boolean-hash #f)))
+    (pass-if (not (negative? (boolean-hash #t))))
+    (pass-if (exact-integer? (char-hash #\a)))
+    (pass-if (not (negative? (char-hash #\b))))
+    (pass-if (exact-integer? (char-ci-hash #\a)))
+    (pass-if (not (negative? (char-ci-hash #\b))))
+    (pass-if (= (char-ci-hash #\a) (char-ci-hash #\A)))
+    (pass-if (exact-integer? (string-hash "f")))
+    (pass-if (not (negative? (string-hash "g"))))
+    (pass-if (exact-integer? (string-ci-hash "f")))
+    (pass-if (not (negative? (string-ci-hash "g"))))
+    (pass-if (= (string-ci-hash "f") (string-ci-hash "F")))
+    (pass-if (exact-integer? (symbol-hash 'f)))
+    (pass-if (not (negative? (symbol-hash 't))))
+    (pass-if (exact-integer? (number-hash 3)))
+    (pass-if (not (negative? (number-hash 3))))
+    (pass-if (exact-integer? (number-hash -3)))
+    (pass-if (not (negative? (number-hash -3))))
+    (pass-if (exact-integer? (number-hash 3.0)))
+    (pass-if (not (negative? (number-hash 3.0))))
+    (pass-if (exact-integer? (number-hash 3.47)))
+    (pass-if (not (negative? (number-hash 3.47))))
+    (pass-if (exact-integer? (default-hash '())))
+    (pass-if (not (negative? (default-hash '()))))
+    (pass-if (exact-integer? (default-hash '(a "b" #\c #(dee) 2.718))))
+    (pass-if (not (negative? (default-hash '(a "b" #\c #(dee) 2.718)))))
+    (pass-if (exact-integer? (default-hash '#u8())))
+    (pass-if (not (negative? (default-hash '#u8()))))
+    (pass-if (exact-integer? (default-hash '#u8(8 6 3))))
+    (pass-if (not (negative? (default-hash '#u8(8 6 3)))))
+    (pass-if (exact-integer? (default-hash '#())))
+    (pass-if (not (negative? (default-hash '#()))))
+    (pass-if (exact-integer? (default-hash '#(a "b" #\c #(dee) 2.718))))
+    (pass-if (not (negative? (default-hash '#(a "b" #\c #(dee) 2.718)))))
+
+    ) ; end comparators/hash
+
+  (with-test-prefix "comparators/default"
+    (pass-if (<? default-comparator '() '(a)))
+    (pass-if (not (=? default-comparator '() '(a))))
+    (pass-if (=? default-comparator #t #t))
+    (pass-if (not (=? default-comparator #t #f)))
+    (pass-if (<? default-comparator #f #t))
+    (pass-if (not (<? default-comparator #t #t)))
+    (pass-if (=? default-comparator #\a #\a))
+    (pass-if (<? default-comparator #\a #\b))
+
+    (pass-if (comparator-test-type default-comparator '()))
+    (pass-if (comparator-test-type default-comparator #t))
+    (pass-if (comparator-test-type default-comparator #\t))
+    (pass-if (comparator-test-type default-comparator '(a)))
+    (pass-if (comparator-test-type default-comparator 'a))
+    (pass-if (comparator-test-type default-comparator (make-bytevector 10)))
+    (pass-if (comparator-test-type default-comparator 10))
+    (pass-if (comparator-test-type default-comparator 10.0))
+    (pass-if (comparator-test-type default-comparator "10.0"))
+    (pass-if (comparator-test-type default-comparator '#(10)))
+
+    (pass-if (=? default-comparator '(#t . #t) '(#t . #t)))
+    (pass-if (not (=? default-comparator '(#t . #t) '(#f . #t))))
+    (pass-if (not (=? default-comparator '(#t . #t) '(#t . #f))))
+    (pass-if (<? default-comparator '(#f . #t) '(#t . #t)))
+    (pass-if (<? default-comparator '(#t . #f) '(#t . #t)))
+    (pass-if (not (<? default-comparator '(#t . #t) '(#t . #t))))
+    (pass-if (not (<? default-comparator '(#t . #t) '(#f . #t))))
+    (pass-if (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+    (pass-if (=? default-comparator '#(#t #t) '#(#t #t)))
+    (pass-if (not (=? default-comparator '#(#t #t) '#(#f #t))))
+    (pass-if (not (=? default-comparator '#(#t #t) '#(#t #f))))
+    (pass-if (<? default-comparator '#(#f #t) '#(#t #t)))
+    (pass-if (<? default-comparator '#(#t #f) '#(#t #t)))
+    (pass-if (not (<? default-comparator '#(#t #t) '#(#t #t))))
+    (pass-if (not (<? default-comparator '#(#t #t) '#(#f #t))))
+    (pass-if (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+    (pass-if (= (comparator-hash default-comparator #t) (boolean-hash #t)))
+    (pass-if (= (comparator-hash default-comparator #\t) (char-hash #\t)))
+    (pass-if (= (comparator-hash default-comparator "t") (string-hash "t")))
+    (pass-if (= (comparator-hash default-comparator 't) (symbol-hash 't)))
+    (pass-if (= (comparator-hash default-comparator 10) (number-hash 10)))
+    (pass-if (= (comparator-hash default-comparator 10.0) (number-hash 10.0)))
+
+    (comparator-register-default!
+     (make-comparator procedure? (lambda (a b) #t) (lambda (a b) #f) (lambda (obj) 200)))
+    (pass-if (=? default-comparator (lambda () #t) (lambda () #f)))
+    (pass-if (not (<? default-comparator (lambda () #t) (lambda () #f))))
+    (pass-if-equal 200 (comparator-hash default-comparator (lambda () #t)))
+
+    ) ; end comparators/default
+
+  ;; SRFI 128 does not actually require a comparator's four procedures
+  ;; to be eq? to the procedures originally passed to make-comparator.
+  ;; For interoperability/interchangeability between the comparators
+  ;; of SRFI 114 and SRFI 128, some of the procedures passed to
+  ;; make-comparator may need to be wrapped inside another lambda
+  ;; expression before they're returned by the corresponding accessor.
+  ;;
+  ;; So this next group of tests is incorrect, hence commented out
+  ;; and replaced by a slightly less naive group of tests.
+
+  #;
+  (with-test-prefix "comparators/accessors"
+  (define ttp (lambda (x) #t))
+  (define eqp (lambda (x y) #t))
+  (define orp (lambda (x y) #t))
+  (define hf (lambda (x) 0))
+  (define comp (make-comparator ttp eqp orp hf))
+  (pass-if-equal ttp (comparator-type-test-predicate comp))
+  (pass-if-equal eqp (comparator-equality-predicate comp))
+  (pass-if-equal orp (comparator-ordering-predicate comp))
+  (pass-if-equal hf (comparator-hash-function comp))
+  ) ; end comparators/accessors
+
+  (with-test-prefix "comparators/accessors"
+    (let* ((x1 0)
+           (x2 0)
+           (x3 0)
+           (x4 0)
+           (ttp (lambda (x) (set! x1 111) #t))
+           (eqp (lambda (x y) (set! x2 222) #t))
+           (orp (lambda (x y) (set! x3 333) #t))
+           (hf (lambda (x) (set! x4 444) 0))
+           (comp (make-comparator ttp eqp orp hf)))
+      (pass-if-equal #t (and ((comparator-type-test-predicate comp) x1)   (= x1 111)))
+      (pass-if-equal #t (and ((comparator-equality-predicate comp) x1 x2) (= x2 222)))
+      (pass-if-equal #t (and ((comparator-ordering-predicate comp) x1 x3) (= x3 333)))
+      (pass-if-equal #t (and (zero? ((comparator-hash-function comp) x1)) (= x4 444))))
+    ) ; end comparators/accessors
+
+  (with-test-prefix "comparators/invokers"
+    (pass-if (comparator-test-type real-comparator 3))
+    (pass-if (comparator-test-type real-comparator 3.0))
+    (pass-if (not (comparator-test-type real-comparator "3.0")))
+    (pass-if (comparator-check-type boolean-comparator #t))
+    (pass-if-exception "check-type"
+        '(misc-error . "^Comparator type check failed")
+      (comparator-check-type boolean-comparator 't))
+    ) ; end comparators/invokers
+
+  (with-test-prefix "comparators/comparison"
+    (pass-if (=? real-comparator 2 2.0 2))
+    (pass-if (<? real-comparator 2 3.0 4))
+    (pass-if (>? real-comparator 4.0 3.0 2))
+    (pass-if (<=? real-comparator 2.0 2 3.0))
+    (pass-if (>=? real-comparator 3 3.0 2))
+    (pass-if (not (=? real-comparator 1 2 3)))
+    (pass-if (not (<? real-comparator 3 1 2)))
+    (pass-if (not (>? real-comparator 1 2 3)))
+    (pass-if (not (<=? real-comparator 4 3 3)))
+    (pass-if (not (>=? real-comparator 3 4 4.0)))
+
+    ) ; end comparators/comparison
+
+  (with-test-prefix "comparators/syntax"
+    (pass-if-equal 'less (comparator-if<=> real-comparator 1 2 'less 'equal 'greater))
+    (pass-if-equal 'equal (comparator-if<=> real-comparator 1 1 'less 'equal 'greater))
+    (pass-if-equal 'greater (comparator-if<=> real-comparator 2 1 'less 'equal 'greater))
+    (pass-if-equal 'less (comparator-if<=> "1" "2" 'less 'equal 'greater))
+    (pass-if-equal 'equal (comparator-if<=> "1" "1" 'less 'equal 'greater))
+    (pass-if-equal 'greater (comparator-if<=> "2" "1" 'less 'equal 'greater))
+
+    ) ; end comparators/syntax
+
+  (with-test-prefix "comparators/bound-salt"
+    (pass-if (exact-integer? (hash-bound)))
+    (pass-if (exact-integer? (hash-salt)))
+    (pass-if (< (hash-salt) (hash-bound)))
+    #;  (pass-if-equal (hash-salt) (fake-salt-hash #t))  ; no such thing as fake-salt-hash
+    ) ; end comparators/bound-salt
+  )
-- 
2.19.1