projects
/
scheme.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (from parent 1:
9d93b06
)
Add clash constraints when merging
typechecker-refactor
author
Luke Lau
<luke_lau@icloud.com>
Thu, 1 Aug 2019 15:35:05 +0000
(16:35 +0100)
committer
Luke Lau
<luke_lau@icloud.com>
Thu, 1 Aug 2019 15:35:05 +0000
(16:35 +0100)
typecheck.scm
patch
|
blob
|
history
diff --git
a/typecheck.scm
b/typecheck.scm
index 6a99869c0697302f361a9e28ac216013f5d018d6..df85cc1607209a6f61968092c4636b7027023142 100644
(file)
--- a/
typecheck.scm
+++ b/
typecheck.scm
@@
-278,9
+278,9
@@
; composes constraints a onto b and merges, i.e. applies a to b
; a should be the "more important" constraints
(define (constraint-merge a b)
; composes constraints a onto b and merges, i.e. applies a to b
; a should be the "more important" constraints
(define (constraint-merge a b)
- (define (f constraint)
+ (define (f c
s c
onstraint)
(cons (car constraint)
(cons (car constraint)
- (substitute
a
(cdr constraint))))
+ (substitute
cs
(cdr constraint))))
(define (most-concrete a b)
(cond
(define (most-concrete a b)
(cond
@@
-293,24
+293,36
@@
[(abs? b) a]
[else (error #f "impossible! most-concrete")]))
[(abs? b) a]
[else (error #f "impossible! most-concrete")]))
- (define (union p q)
- (cond
- [(null? p) q]
- [(null? q) p]
- [else
- (let ([x (car q)])
- (if (assoc (car x) p)
- (if (eqv? (most-concrete (cddr (assoc (car x) p))
- (cdr x))
- (cdr x))
- (cons x (union (filter (p) (not (eqv?
+ (define (clashes)
+ (define (gen acc x)
+ (if (assoc (car x) a)
+ (cons (cons (car x) (most-concrete (cdr (assoc (car x) a))
+ (cdr x)))
+ acc)
+ acc))
+ (fold-left gen '() b))
+
+ ;; (define (union p q)
+ ;; (cond
+ ;; [(null? p) q]
+ ;; [(null? q) p]
+ ;; [else
+ ;; (let ([x (car q)])
+ ;; (if (assoc (car x) p)
+ ;; (if (eqv? (most-concrete (cddr (assoc (car x) p))
+ ;; (cdr x))
+ ;; (cdr x))
+ ;; (cons x (union (filter (p) (not (eqv?
(define (union p q)
(append (filter (lambda (x) (not (assoc (car x) p)))
q)
p))
(define (union p q)
(append (filter (lambda (x) (not (assoc (car x) p)))
q)
p))
- (union a (map f b)))
+ (display "clashes: ")
+ (display (clashes))
+ (newline)
+ (append (clashes) (union a (map (lambda (z) (f a z)) b))))
;; ; a1 -> a2 ~ a3 -> a4;
;; ; a1 -> a2 ~ a3 -> a4;