Good find, thanks megane. Here's a signoff. I refactored it a bit to avoid the `begin' and `set!' inside the cond clause.
Could someone have a look at this, please, as well as the signoff for megane's other patch from 30/3 (re: typematch-tests.scm)? Thanks, Evan
>From 45499d633b15103d658c2fc319d39e709b024a0a Mon Sep 17 00:00:00 2001 From: megane <megan...@gmail.com> Date: Mon, 14 May 2018 21:59:05 +1200 Subject: [PATCH] Fix error during compiler-typecase trail restore This fixes an error that can occur when a typecase clause fails to match and the subsequent trail restoration fails due to an incorrect environment being passed to `trail-restore'. This argument should be the one used for matching, not the original environment containing just the source expression's types. Signed-off-by: Evan Hanson <ev...@foldling.org> --- scrutinizer.scm | 37 ++++++++++++++++++------------------- tests/scrutiny-tests.scm | 5 +++++ 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/scrutinizer.scm b/scrutinizer.scm index 4869cc6b..ece07ed3 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -850,27 +850,26 @@ ((##core#typecase) (let* ((ts (walk (first subs) e loc #f #f flow ctags)) (trail0 trail) - (typeenv (type-typeenv (car ts)))) + (typeenv0 (type-typeenv (car ts)))) ;; first exp is always a variable so ts must be of length 1 (let loop ((types (cdr params)) (subs (cdr subs))) - (cond ((null? types) - (quit-compiling - "~a~ano clause applies in `compiler-typecase' for expression of type `~a':~a" - (location-name loc) - (node-source-prefix n) - (type-name (car ts)) - (string-intersperse - (map (lambda (t) (sprintf "\n ~a" (type-name t))) - (cdr params)) ""))) - ((match-types (car types) (car ts) - (append (type-typeenv (car types)) typeenv) - #t) - ;; drops exp - (mutate-node! n (car subs)) - (walk n e loc dest tail flow ctags)) - (else - (trail-restore trail0 typeenv) - (loop (cdr types) (cdr subs))))))) + (if (null? types) + (quit-compiling + "~a~ano clause applies in `compiler-typecase' for expression of type `~a':~a" + (location-name loc) + (node-source-prefix n) + (type-name (car ts)) + (string-intersperse + (map (lambda (t) (sprintf "\n ~a" (type-name t))) + (cdr params)) "")) + (let ((typeenv (append (type-typeenv (car types)) typeenv0))) + (if (match-types (car types) (car ts) typeenv #t) + (begin ; drops exp + (mutate-node! n (car subs)) + (walk n e loc dest tail flow ctags)) + (begin + (trail-restore trail0 typeenv) + (loop (cdr types) (cdr subs))))))))) ((##core#switch ##core#cond) (bomb "scrutinize: unexpected node class" class)) (else diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm index ef4e0d96..96757b7e 100644 --- a/tests/scrutiny-tests.scm +++ b/tests/scrutiny-tests.scm @@ -311,3 +311,8 @@ (define (append-result-type-nowarn2) (add1 (list-ref l2 1)))) (let ((l3 (append (the (list-of fixnum) '(1 2)) '(x y)))) (define (append-result-type-nowarn3) (add1 (list-ref l3 1)))) + +;; Check the trail is restored from the combined typeenv +(compiler-typecase (list 2 'a) + ((forall (x) (list x x)) 1) + (else #t)) -- 2.11.0
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
