[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] [PATCH] simplify typevar instantiation handling in
|
From: |
Felix |
|
Subject: |
Re: [Chicken-hackers] [PATCH] simplify typevar instantiation handling in scrutinizer |
|
Date: |
Mon, 26 Sep 2011 13:27:54 +0200 (CEST) |
From: Felix <address@hidden>
Subject: [PATCH] simplify typevar instantiation handling in scrutinizer
Date: Mon, 26 Sep 2011 09:23:02 +0200 (CEST)
> Attached is a patch that simplifies the use of
> "over-all-instantiations" in the scrutinizer. Peter was of course
> right about the redundant matching at some call-sites of this
> procedure, which I boneheadedly refused to see.
>
> This patch also fixes a bug in the transformation of the internal
> node tree to s-expressions for the "##core#typecase" construct.
>
> Testcases have been added. The changes have been tested with the
> core test-suite and all core libraries and tools.
Please ignore the previous patch. This new one contains an additional
fix in "type<=?" (subtype checking).
cheers,
felix
>From 2ab58471a67b474197714aeb98a17a44b6ca8416 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sun, 25 Sep 2011 15:26:04 +0200
Subject: [PATCH] simplified o-a-i, fallback to * for unbound typevars only in
exact mode, fixed bug in build-expression-tree for typecase
---
scrutinizer.scm | 46 ++++++++++++++++++++++----------------------
support.scm | 4 ++-
tests/typematch-tests.scm | 13 ++++++++++++
3 files changed, 39 insertions(+), 24 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 115b118..176129b 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1015,19 +1015,15 @@
((and (pair? t2) (eq? 'or (car t2)))
(over-all-instantiations
(cdr t2)
- typeenv
- (lambda (t) (match1 t1 t))
- (lambda ()
- (if (or exact all)
- (every
- (cut match1 t1 <>)
- (cdr t2))
- #t))))
+ typeenv
+ (or exact all)
+ (lambda (t) (match1 t1 t))))
;; s.a.
((and (pair? t1) (eq? 'or (car t1)))
(over-all-instantiations
(cdr t1)
typeenv
+ #f
(lambda (t) (match1 t t2)))) ; o-a-i ensures at least one element
matches
((and (pair? t1) (eq? 'forall (car t1)))
(match1 (third t1) t2)) ; assumes typeenv has already been extracted
@@ -1435,9 +1431,8 @@
(over-all-instantiations
(cdr t2)
typeenv
- (lambda (t) (test t1 t))
- (lambda ()
- (every (cut test t1 <>) (cdr t2)))))
+ #t
+ (lambda (t) (test t1 t))))
((and (eq? 'vector (car t1)) (eq? 'vector-of (car
t2)))
(every (cute test <> (second t2)) (cdr t1)))
((and (eq? 'vector-of (car t1)) (eq? 'vector (car
t2)))
@@ -1462,9 +1457,8 @@
(over-all-instantiations
(cdr t1)
typeenv
- (lambda (t) (test t t2))
- (lambda ()
- (every (cut test <> t2) (cdr t1)))))
+ #t
+ (lambda (t) (test t t2))))
((vector-of list-of) (test (second t1) (second
t2)))
((pair) (every test (cdr t1) (cdr t2)))
((procedure)
@@ -2277,7 +2271,7 @@
;;; perform check over all typevar instantiations
-(define (over-all-instantiations tlist typeenv process #!optional (combine
(constantly #t)))
+(define (over-all-instantiations tlist typeenv exact process)
(let ((insts '())
(anyinst #f)
(trail0 trail))
@@ -2306,15 +2300,17 @@
(all (map (lambda (var)
(cons
var
- (map (lambda (inst)
- (cond ((assq var inst) => cdr)
- (else '*)))
- insts)))
+ (append-map
+ (lambda (inst)
+ (cond ((assq var inst) => (o list cdr))
+ (exact '(*))
+ (else '())))
+ insts)))
vars)))
- ;;(dd " collected: ~s" all) ;XXX remove
+ (dd " collected: ~s" all) ;XXX remove
all))
- (dd " over-all-instantiations: ~s" tlist) ;XXX remove
+ (dd " over-all-instantiations: ~s exact=~a" tlist exact) ;XXX remove
;; process all tlist elements
(let loop ((ts tlist) (ok #f))
(cond ((null? ts)
@@ -2322,13 +2318,17 @@
(for-each
(lambda (i)
(set! trail (cons (car i) trail))
- (set-car! (cdr (assq (car i) typeenv)) `(or ,@(cdr i))))
+ (set-car! (cdr (assq (car i) typeenv))
+ (simplify-type `(or ,@(cdr i)))))
(collect))
- (combine))
+ #t)
(else #f)))
((process (car ts))
(restore)
(loop (cdr ts) #t))
+ (exact
+ (restore)
+ #f)
(else
(restore)
(loop (cdr ts) ok))))))
diff --git a/support.scm b/support.scm
index 299b92f..cb95c0d 100644
--- a/support.scm
+++ b/support.scm
@@ -595,7 +595,9 @@
,(walk (first subs))
,@(let loop ((types params) (bodies (cdr subs)))
(if (null? types)
- `((else ,(walk (car bodies))))
+ (if (null? bodies)
+ '()
+ `((else ,(walk (car bodies)))))
(cons (list (car types) (walk (car bodies)))
(loop (cdr types) (cdr bodies)))))))
((##core#call)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index a1048f4..3e4b759 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -211,3 +211,16 @@
(symbol 's)
(fixnum 'f)
((or fixnum symbol) 'sf))))
+
+(: f3 (forall (a) ((list-of a) -> a)))
+(define (f3 x) (car x))
+(define xxx '(1))
+
+(compiler-typecase (foo (the (or (vector-of fixnum) (list-of fixnum)) xxx))
+ (fixnum 'ok))
+
+(assert
+ (eq? 'ok
+ (compiler-typecase (list 123)
+ ((forall (a) (or (vector-of a) (list-of a))) 'ok)
+ (else 'not-ok))))
--
1.6.0.4
>From 56299cdc71ccbc6342b4614014536b715ff3747c Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Mon, 26 Sep 2011 08:34:10 +0200
Subject: [PATCH] added some testcases
---
scrutinizer.scm | 2 +-
tests/typematch-tests.scm | 18 +++++++++++++++---
2 files changed, 16 insertions(+), 4 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 176129b..3f9ebfd 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2307,7 +2307,7 @@
(else '())))
insts)))
vars)))
- (dd " collected: ~s" all) ;XXX remove
+ ;;(dd " collected: ~s" all) ;XXX remove
all))
(dd " over-all-instantiations: ~s exact=~a" tlist exact) ;XXX remove
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 3e4b759..6b687c8 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -1,7 +1,7 @@
;;;; typematch-tests.scm
-(use lolevel)
+(use lolevel data-structures)
(define-syntax check
@@ -213,10 +213,10 @@
((or fixnum symbol) 'sf))))
(: f3 (forall (a) ((list-of a) -> a)))
-(define (f3 x) (car x))
+(define f3 car)
(define xxx '(1))
-(compiler-typecase (foo (the (or (vector-of fixnum) (list-of fixnum)) xxx))
+(compiler-typecase (f3 (the (or (vector-of fixnum) (list-of fixnum)) xxx))
(fixnum 'ok))
(assert
@@ -224,3 +224,15 @@
(compiler-typecase (list 123)
((forall (a) (or (vector-of a) (list-of a))) 'ok)
(else 'not-ok))))
+
+(: f4 (forall (a) ((or fixnum (list-of a)) -> a)))
+(define f4 identity)
+
+(compiler-typecase (f4 '(1))
+ (fixnum 'ok))
+
+(assert
+ (eq? 'ok (compiler-typecase (f4 1)
+ (fixnum 'not-ok)
+ (else 'ok))))
+
--
1.6.0.4
>From 4c46a5f58ab4c9e4effc985606789915db2ebfd9 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Mon, 26 Sep 2011 13:18:35 +0200
Subject: [PATCH] fixed incorrect generalization of simple list/vector types
---
scrutinizer.scm | 3 ++-
1 files changed, 2 insertions(+), 1 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3f9ebfd..d74a1d0 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1409,7 +1409,8 @@
(test t1 (third e)))))))
((memq t2 '(* undefined)))
((eq? 'pair t1) (test '(pair * *) t2))
- ((memq t1 '(vector list)) (test `(,t1 *) t2))
+ ((eq? 'vector t1) (test '(vector-of *) t2))
+ ((eq? 'list t1) (test '(list-of *) t2))
((and (eq? 'null t1)
(pair? t2)
(eq? (car t2) 'list-of)))
--
1.6.0.4