~ chicken-core (chicken-5) fead35de0c2cf740434229e92c72588f9ae535f8
commit fead35de0c2cf740434229e92c72588f9ae535f8
Author: megane <meganeka@gmail.com>
AuthorDate: Sun Mar 24 09:49:00 2019 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Mar 31 15:50:51 2019 +1300
Remove renaming detail from printed type variables
Signed-off-by: Peter Bex <peter@more-magic.net>
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index b728d5eb..0816e02d 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -43,6 +43,7 @@
chicken.io
chicken.pathname
chicken.platform
+ chicken.plist
chicken.port
chicken.pretty-print
chicken.string
@@ -107,6 +108,7 @@
; ##compiler#special-result-type -> PROCEDURE
; ##compiler#escape -> #f | 'yes | 'no
; ##compiler#type-abbreviation -> TYPESPEC
+;; ##compiler#tv-root -> STRING
;
; specialization specifiers:
;
@@ -1104,7 +1106,7 @@
(set! typeenv
(append (map (lambda (v)
(let ((v (if (symbol? v) v (first v))))
- (cons v (gensym v))))
+ (cons v (make-tv v))))
typevars)
typeenv))
(set! constraints
@@ -1475,6 +1477,13 @@
;;; Type-environments and -variables
+(define (make-tv sym)
+ (let* ((r (get sym '##core#tv-root))
+ ;; ##core#tv-root is a string to make this gensym fast
+ (new (gensym r)))
+ (put! new '##core#tv-root r)
+ new))
+
(define (type-typeenv t)
(let ((te '()))
(let loop ((t t))
@@ -1926,6 +1935,7 @@
(set! type
`(forall
,(map (lambda (tv)
+ (put! tv '##core#tv-root (symbol->string (strip-syntax tv)))
(cond ((assq tv constraints) => identity)
(else tv)))
(delete-duplicates typevars eq?))
@@ -2347,6 +2357,10 @@
s)))
(define (type->pp-string t)
+ (define (pp-tv tv)
+ (let ((r (get tv '##core#tv-root)))
+ (assert r (list tv: tv))
+ (list 'quote (string->symbol r))))
(define (conv t #!optional (tv-replacements '()))
(define (R t) (conv t tv-replacements))
(cond
@@ -2359,7 +2373,7 @@
(let ((tcar (and (pair? t) (car t))))
(cond
((and (eq? 'forall tcar) (every symbol? (second t))) ; no constraints
- (let ((tvs (map (lambda (tv) (cons tv (list 'quote tv))) (second t))))
+ (let ((tvs (map (lambda (tv) (cons tv (pp-tv tv))) (second t))))
(conv (third t) tvs)))
((eq? 'forall tcar) t) ; forall with constraints, do nothing
((memq tcar '(or not list vector pair list-of vector-of))
diff --git a/tests/scrutinizer-message-format.expected b/tests/scrutinizer-message-format.expected
index f6f3b256..d8f2aa55 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -16,7 +16,7 @@ Warning: Wrong number of arguments
Procedure `cons' from module `scheme' has this type:
- ('aXXX 'bXXX --> (pair 'aXXX 'bXXX))
+ ('a 'b --> (pair 'a 'b))
Warning: Invalid argument
In file `test-scrutinizer-message-format.scm:XXX',
@@ -425,7 +425,7 @@ Warning: Wrong number of arguments
Procedure `cons' from module `scheme' has this type:
- ('aXXX 'bXXX --> (pair 'aXXX 'bXXX))
+ ('a 'b --> (pair 'a 'b))
Warning: Invalid argument
In file `test-scrutinizer-message-format.scm:XXX',
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index cc01b6fb..a16541c0 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -185,7 +185,7 @@ Warning: Invalid assignment
The declared type of `car' from module `scheme' is:
- ((pair 'a335 *) -> 'a335)
+ ((pair 'a *) -> 'a)
Warning: Let binding to `gXXX' has 2 values
In file `scrutiny-tests.scm:XXX',
@@ -564,7 +564,7 @@ Warning: Invalid argument
Procedure `apply1' has this type:
- ((#!rest 'a143 -> 'b144) (list-of 'a143) -> 'b144)
+ ((#!rest 'a -> 'b) (list-of 'a) -> 'b)
Warning: Invalid argument
In file `scrutiny-tests.scm:XXX',
@@ -583,7 +583,7 @@ Warning: Invalid argument
It is a call to `cons' from module `scheme' which has this type:
- ('a331 'b332 -> (pair 'a331 'b332))
+ ('a 'b -> (pair 'a 'b))
This is the expression:
@@ -591,7 +591,7 @@ Warning: Invalid argument
Procedure `apply1' has this type:
- ((#!rest 'a143 -> 'b144) (list-of 'a143) -> 'b144)
+ ((#!rest 'a -> 'b) (list-of 'a) -> 'b)
Note: Predicate is always true
In file `scrutiny-tests.scm:XXX',
@@ -834,7 +834,7 @@ Warning: Invalid argument
It is a call to `cons' from module `scheme' which has this type:
- ('a331 'b332 -> (pair 'a331 'b332))
+ ('a 'b -> (pair 'a 'b))
This is the expression:
@@ -892,7 +892,7 @@ Warning: Invalid argument
Procedure `vector-ref' from module `scheme' has this type:
- ((vector-of 'a384) fixnum -> 'a384)
+ ((vector-of 'a) fixnum -> 'a)
Warning: Negative vector index
In file `scrutiny-tests.scm:XXX',
@@ -1010,7 +1010,7 @@ Warning: Invalid argument
Procedure `list-ref' from module `scheme' has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
Warning: Invalid argument
In file `scrutiny-tests.scm:XXX',
@@ -1033,7 +1033,7 @@ Warning: Invalid argument
Procedure `list-ref' from module `scheme' has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
Warning: Invalid argument
In file `scrutiny-tests.scm:XXX',
@@ -1056,7 +1056,7 @@ Warning: Invalid argument
Procedure `list-ref' from module `scheme' has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
Warning: Invalid argument
In file `scrutiny-tests.scm:XXX',
@@ -1079,7 +1079,7 @@ Warning: Invalid argument
Procedure `list-ref' from module `scheme' has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
Warning: Invalid argument
In file `scrutiny-tests.scm:XXX',
@@ -1098,7 +1098,7 @@ Warning: Invalid argument
It is a call to `list-ref' from module `scheme' which has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
This is the expression:
@@ -1125,7 +1125,7 @@ Warning: Invalid argument
It is a call to `list-ref' from module `scheme' which has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
This is the expression:
@@ -1152,7 +1152,7 @@ Warning: Invalid argument
It is a call to `list-ref' from module `scheme' which has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
This is the expression:
@@ -1179,7 +1179,7 @@ Warning: Invalid argument
It is a call to `list-ref' from module `scheme' which has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
This is the expression:
@@ -1206,7 +1206,7 @@ Warning: Invalid argument
It is a call to `list-ref' from module `scheme' which has this type:
- ((list-of 'a366) fixnum -> 'a366)
+ ((list-of 'a) fixnum -> 'a)
This is the expression:
Trap