This patch changes the code in the scrutinizer to output types
file entries in sorted order.
See also #1783.
felix
From 7e2755629501a029c997ec5773186567c61b3f84 Mon Sep 17 00:00:00 2001
From: felix
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
---
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 (symbolstring 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
