~ chicken-core (chicken-5) d65ccd18e5f20db69f822ab9ab8c1608bc4090d6
commit d65ccd18e5f20db69f822ab9ab8c1608bc4090d6
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Aug 16 16:42:07 2014 +1200
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Oct 19 14:04:24 2014 +0200
Walk nested pair types in special-cased scrutiny for list-ref/list-tail
Also, remove the unused ##sys#list-ref alias and its special case.
Fixes #759.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/library.scm b/library.scm
index 74980fbf..fb85c860 100644
--- a/library.scm
+++ b/library.scm
@@ -4763,7 +4763,6 @@ EOF
(define ##sys#list? list?)
(define ##sys#null? null?)
(define ##sys#map-n map)
-(define ##sys#list-ref list-ref)
;;; Promises:
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3af3fab7..fd783b95 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2183,42 +2183,60 @@
(define-special-case vector-ref vector-ref-result-type)
(define-special-case ##sys#vector-ref vector-ref-result-type))
+
+;;; List-related special cases
+;
+; Preserve known element types for list-ref, list-tail.
+
(let ()
- (define (list-ref-result-type node args rtypes)
- (or (and-let* ((subs (node-subexpressions node))
- ((= (length subs) 3))
- (arg1 (walked-result (second args)))
- ((pair? arg1))
- ((eq? 'list (car arg1)))
- (index (third subs))
- ((eq? 'quote (node-class index)))
- (val (first (node-parameters index)))
- ((fixnum? val))
- ((>= val 0)) ;XXX could warn on failure (but needs location)
- ((< val (length (cdr arg1)))))
- (list (list-ref (cdr arg1) val)))
- rtypes))
- (define-special-case list-ref list-ref-result-type)
- (define-special-case ##sys#list-ref list-ref-result-type))
-(define-special-case list-tail
- (lambda (node args rtypes)
- (or (and-let* ((subs (node-subexpressions node))
- ((= (length subs) 3))
- (arg1 (walked-result (second args)))
- ((pair? arg1))
- ((eq? 'list (car arg1)))
- (index (third subs))
- ((eq? 'quote (node-class index)))
- (val (first (node-parameters index)))
- ((fixnum? val))
- ((>= val 0))
- ((<= val (length (cdr arg1))))) ;XXX could warn on failure (but needs location)
- (let ((rest (list-tail (cdr arg1) val)))
- (list (if (null? rest)
- 'null
- `(list ,@rest)))))
- rtypes)))
+ (define (list-or-null a)
+ (if (null? a) 'null `(list ,@a)))
+
+ ;; Split a list or pair type form at index i, calling k with the two
+ ;; sections of the type or returning #f if it doesn't match that far.
+ (define (split-list-type l i k)
+ (cond ((not (pair? l))
+ (and (fx= i 0) (eq? l 'null) (k l l)))
+ ((eq? (first l) 'list)
+ (and (fx< i (length l))
+ (receive (left right) (split-at (cdr l) i)
+ (k (list-or-null left)
+ (list-or-null right)))))
+ ((eq? (first l) 'pair)
+ (let lp ((a '()) (l l) (i i))
+ (cond ((fx= i 0)
+ (k (list-or-null (reverse a)) l))
+ ((and (pair? l)
+ (eq? (first l) 'pair))
+ (lp (cons (second l) a)
+ (third l)
+ (sub1 i)))
+ (else #f))))
+ (else #f)))
+
+ (define (list+index-call-result-type-special-case k)
+ (lambda (node args rtypes)
+ (or (and-let* ((subs (node-subexpressions node))
+ ((= (length subs) 3))
+ (arg1 (walked-result (second args)))
+ (index (third subs))
+ ((eq? 'quote (node-class index)))
+ (val (first (node-parameters index)))
+ ((fixnum? val))
+ ((>= val 0)))
+ (split-list-type arg1 val k))
+ rtypes)))
+
+ (define-special-case list-ref
+ (list+index-call-result-type-special-case
+ (lambda (_ result-type)
+ (and (pair? result-type)
+ (list (cadr result-type))))))
+
+ (define-special-case list-tail
+ (list+index-call-result-type-special-case
+ (lambda (_ result-type) (list result-type)))))
(define-special-case list
(lambda (node args rtypes)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 6cbcc9a6..85ada83f 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -49,9 +49,11 @@
(define-syntax mx
(syntax-rules ()
((_ t x)
- (compiler-typecase
- x
- (t 'ok)))))
+ (begin
+ (print 'x " = " 't)
+ (compiler-typecase
+ x
+ (t 'ok))))))
(define-syntax mn
(er-macro-transformer
@@ -266,6 +268,14 @@
(mx (list fixnum float) (list-copy (list 1 2.3)))
(mx (pair fixnum float) (list-copy (cons 1 2.3)))
(mx fixnum (list-copy 1))
+(mx fixnum (list-ref (list 1 2.3) 0))
+(mx fixnum (list-ref (cons 1 2.3) 0))
+(mx float (list-ref (list 1 2.3) 1))
+(mx (list fixnum float) (list-tail (list 1 2.3) 0))
+(mx (pair fixnum float) (list-tail (cons 1 2.3) 0))
+(mx (list float) (list-tail (list 1 2.3) 1))
+(mx float (list-tail (cons 1 2.3) 1))
+(mx null (list-tail (list 1 2.3) 2))
(: f1 (forall (a) ((list-of a) -> a)))
(define (f1 x) (car x))
Trap