[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] Remove renaming detail from printed type varia
From: |
megane |
Subject: |
[Chicken-hackers] [PATCH] Remove renaming detail from printed type variables |
Date: |
Sun, 24 Mar 2019 10:02:52 +0200 |
User-agent: |
mu4e 1.0; emacs 25.1.1 |
Hi,
Here's a version of tv renaming using the plist approach Peter
suggested.
The original root symbol is not tracked as it's not needed. If there's a
need, ##core#tv-parent or somesuch could be used for tracking the
renaming chain.
>From 96799cf650b84cd02f107ec9a48c73cb51e71561 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 24 Mar 2019 09:49:00 +0200
Subject: [PATCH] Remove renaming detail from printed type variables
---
scrutinizer.scm | 18 ++++++++++++++++--
tests/scrutinizer-message-format.expected | 4 ++--
tests/scrutiny.expected | 30 +++++++++++++++---------------
3 files changed, 33 insertions(+), 19 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 7d767df..66147b9 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 f6f3b25..d8f2aa5 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 cc01b6f..a16541c 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:
--
2.7.4
- [Chicken-hackers] [PATCH] Remove renaming detail from printed type variables,
megane <=