From 7e2755629501a029c997ec5773186567c61b3f84 Mon Sep 17 00:00:00 2001
From: felix <felix@call-with-current-continuation.org>
Date: Fri, 21 Oct 2022 15:49:04 +0200
Subject: [PATCH] make order of entries in types-files deterministic

See #1783

Signed-off-by: felix <felix@call-with-current-continuation.org>
---
 rules.make      |  1 +
 scrutinizer.scm | 81 ++++++++++++++++++++++++++++++-------------------
 2 files changed, 51 insertions(+), 31 deletions(-)

diff --git a/rules.make b/rules.make
index ec714550..71588a63 100644
--- a/rules.make
+++ b/rules.make
@@ -586,6 +586,7 @@ scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \
 		chicken.io.import.scm \
 		chicken.pathname.import.scm \
 		chicken.platform.import.scm \
+		chicken.sort.import.scm \
 		chicken.port.import.scm \
 		chicken.pretty-print.import.scm \
 		chicken.string.import.scm
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 69872075..0f7651b7 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -45,6 +45,7 @@
 	chicken.pathname
 	chicken.platform
 	chicken.plist
+	chicken.sort
 	chicken.port
 	chicken.pretty-print
 	chicken.string
@@ -1680,42 +1681,60 @@
        (call-with-input-file dbfile read-expressions))
       #t)))
 
+(define (hash-table->list ht)
+  (let ((len (vector-length ht)))
+    (let loop1 ((i 0) (lst '()))
+      (if (>= i len)
+          lst
+          (let loop2 ((bl (vector-ref ht i))
+                      (lst lst))
+            (if (null? bl)
+                (loop1 (add1 i) lst)
+                (loop2 (cdr bl)
+                       (cons (cons (caar bl) (cdar bl)) lst))))))))
+
+(define (symbol<? s1 s2)
+  (string<? (symbol->string s1)
+            (symbol->string s2)))
+
 (define (emit-types-file source-file types-file db block-compilation)
   (with-output-to-file types-file
     (lambda ()
       (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
 	     source-file "\n")
-      (hash-table-for-each
-       (lambda (sym plist)
-	 (when (and (variable-visible? sym block-compilation)
-		    (memq (variable-mark sym '##compiler#type-source) '(local inference)))
-	   (let ((specs (or (variable-mark sym '##compiler#specializations) '()))
-		 (type (variable-mark sym '##compiler#type))
-		 (pred (variable-mark sym '##compiler#predicate))
-		 (pure (variable-mark sym '##compiler#pure))
-		 (clean (variable-mark sym '##compiler#clean))
-		 (enforce (variable-mark sym '##compiler#enforce))
-		 (foldable (variable-mark sym '##compiler#foldable)))
-	     (pp (cons*
-		  sym
-		  (let wrap ((type type))
-		    (if (pair? type)
-			(case (car type)
-			  ((procedure)
-			   `(#(procedure
-			       ,@(if enforce '(#:enforce) '())
-			       ,@(if pred `(#:predicate ,pred) '())
-			       ,@(if pure '(#:pure) '())
-			       ,@(if clean '(#:clean) '())
-			       ,@(if foldable '(#:foldable) '()))
-			     ,@(cdr type)))
-			  ((forall)
-			   `(forall ,(second type) ,(wrap (third type))))
-			  (else type))
-			type))
-		  specs))
-	     (newline))))
-       db)
+      (for-each
+       (lambda (p)
+         (let ((sym (car p))
+               (plist (cdr p)))
+           (when (and (variable-visible? sym block-compilation)
+                      (memq (variable-mark sym '##compiler#type-source) '(local inference)))
+             (let ((specs (or (variable-mark sym '##compiler#specializations) '()))
+                   (type (variable-mark sym '##compiler#type))
+                   (pred (variable-mark sym '##compiler#predicate))
+                   (pure (variable-mark sym '##compiler#pure))
+                   (clean (variable-mark sym '##compiler#clean))
+                   (enforce (variable-mark sym '##compiler#enforce))
+                   (foldable (variable-mark sym '##compiler#foldable)))
+               (pp (cons* sym
+                          (let wrap ((type type))
+                            (if (pair? type)
+                                (case (car type)
+                                  ((procedure)
+                                   `(#(procedure
+                                                 ,@(if enforce '(#:enforce) '())
+                                                 ,@(if pred `(#:predicate ,pred) '())
+                                                 ,@(if pure '(#:pure) '())
+                                                 ,@(if clean '(#:clean) '())
+                                                 ,@(if foldable '(#:foldable) '()))
+                                                 ,@(cdr type)))
+                                  ((forall)
+                                   `(forall ,(second type) ,(wrap (third type))))
+                                  (else type))
+                                type))
+                          specs))
+               (newline)))))
+       (sort (hash-table->list db) 
+             (lambda (a b) (symbol<? (car a) (car b)))))
       (print "; END OF FILE"))))
 
 ;;
-- 
2.28.0