From b8c67d481fe7527aefdfa765cb31aa250ed8a90a Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Wed, 26 Apr 2023 16:20:23 -0500
Subject: [PATCH] Fix hash-table construction on Allegro CL.

Allegro, like other lisps, permits non-standard values for `:test` and
we should change the hash function accordingly.
---
 graph.lisp | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/graph.lisp b/graph.lisp
index 97ff5d2..a68c83a 100644
--- a/graph.lisp
+++ b/graph.lisp
@@ -239,7 +239,7 @@
   #+(or ccl lispworks)
   (make-hash-table :test 'edge-equalp :hash-function 'sxhash-edge)
   #+allegro
-  (make-hash-table :test 'edge-equalp)
+  (make-hash-table :test 'edge-equalp :hash-function 'sxhash-edge)
   #+ecl
   (make-hash-table :test 'edge-equalp :hash-function 'sxhash-edge)
   #-(or sbcl clisp ccl allegro lispworks ecl)
@@ -253,7 +253,7 @@
   #+(or ccl lispworks)
   (make-hash-table :test 'dir-edge-equalp :hash-function 'sxhash)
   #+allegro
-  (make-hash-table :test 'dir-edge-equalp)
+  (make-hash-table :test 'dir-edge-equalp :hash-function 'sxhash)
   #+ecl
   (make-hash-table :test 'dir-edge-equalp :hash-function 'sxhash)
   #-(or sbcl clisp ccl allegro lispworks ecl)
@@ -291,6 +291,11 @@ to a new equality test specified with TEST."
           :hash-function (case (or test (hash-table-test hash))
                            (edge-equalp 'sxhash-edge)
                            ((dir-edge-equalp equalp) 'sxhash)))
+         #+allegro
+         (make-hash-table :test (or test (hash-table-test hash))
+                          :hash-function (case (or test (hash-table-test hash))
+                                           (edge-equalp 'sxhash-edge)
+                                           ((dir-edge-equalp equalp) 'sxhash)))
          #+ecl
          (make-hash-table
           :test (or test (hash-table-test hash))
@@ -298,7 +303,7 @@ to a new equality test specified with TEST."
                            (cond ((eql test #'edge-equalp) 'sxhash-edge)
                                  ((member test (list #'dir-edge-equalp #'equalp))
                                   'sxhash))))
-         #-(or sbcl clisp ccl lispworks ecl)
+         #-(or sbcl clisp ccl lispworks ecl allegro)
          (error "unsupported lisp distribution")))
     (maphash (lambda (k v) (setf (gethash k copy)
                             (if (and (gethash k copy) comb)
@@ -1487,4 +1492,5 @@ the `cdr' holds the nodes in the ordering."))
 
 (defmethod k-cores ((graph graph))
   (multiple-value-bind (k cores) (degeneracy graph)
-    (declare (ignorable k)) cores))
+    (declare (ignorable k))
+    cores))