~ chicken-core (chicken-5) 1d531d1c2b325aaa4b8605c34398768b89843232
commit 1d531d1c2b325aaa4b8605c34398768b89843232
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Oct 21 15:49:04 2022 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri Oct 28 10:32:25 2022 +1300
make order of entries in types-files deterministic
See #1783
Signed-off-by: felix <felix@call-with-current-continuation.org>
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/rules.make b/rules.make
index 9c0c4fa8..222035fe 100644
--- a/rules.make
+++ b/rules.make
@@ -584,6 +584,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..4204470f 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"))))
;;
Trap