> * felix winkelmann <[email protected]> [120815 21:40]: >> Type-specifiers given in "##core#typecase"/"compiler-typecase" >> forms must be validated, as the validation resolved type-aliases >> created with "define-type". >> >> Reported by, guess who? megane. Should fix #897. > > This fails the scrutiny test for me: >
Sorry - the "fix" didn't handle the "else" case in clauses correctly. Attached is a new version of the patch. I also moved all type-validation into the expansion/canonicalization of user forms (in some cases this was done for "##core#..." forms). The advantage is more consistency and better error-reporting but code expanding into the core forms needs to perform type-validation (as this resolves type-variables). This is not needed in user code, but must be kept in mind for macros in the core system. The change looks more involved than it actually is, due to some re-factoring. All tests pass for me. cheers, felix
>From ecc8434218cc17eec2d47e544931d39964ec4259 Mon Sep 17 00:00:00 2001 From: felix <[email protected]> Date: Wed, 15 Aug 2012 21:34:01 +0200 Subject: [PATCH] Validate type given to ##core#typecase. Type-specifiers given in "##core#typecase"/"compiler-typecase" forms must be validated, as the validation resolved type-aliases created with "define-type". Moreover all type-validation takes place when type-specifiers are expanded/canonicalized (":", "compiler-typecase", "the", ...) and not when processing the "##core#..." forms. --- chicken-syntax.scm | 67 +++++++++++++++++++++++++----------------------- compiler-namespace.scm | 1 + compiler.scm | 2 +- scrutinizer.scm | 49 ++++++++++++++++++---------------- 4 files changed, 63 insertions(+), 56 deletions(-) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index 4c1161b..c8f0f63 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -1169,6 +1169,7 @@ '(##core#undefined) (let* ((type1 (##sys#strip-syntax (caddr x))) (name1 (cadr x))) + ;; we need pred/pure info, so not using "##compiler#check-and-validate-type" (let-values (((type pred pure) (##compiler#validate-type type1 (##sys#strip-syntax name1)))) (cond ((not type) @@ -1184,13 +1185,17 @@ (##sys#er-transformer (lambda (x r c) (##sys#check-syntax 'the x '(_ _ _)) - `(##core#the ,(##sys#strip-syntax (cadr x)) #t ,(caddr x))))) + (if (not (memq #:compiling ##sys#features)) + (caddr x) + `(##core#the ,(##compiler#check-and-validate-type (cadr x) 'the) + #t + ,(caddr x)))))) (##sys#extend-macro-environment 'assume '() (syntax-rules () ((_ ((var type) ...) body ...) - (let ((var (##core#the type #t var)) ...) body ...)))) + (let ((var (the type var)) ...) body ...)))) (##sys#extend-macro-environment 'define-specialization '() @@ -1225,13 +1230,9 @@ (cons atypes (if (and rtypes (pair? rtypes)) (list - (map (lambda (rt) - (let-values (((t pred pure) - (##compiler#validate-type rt #f))) - (or t - (syntax-error - 'define-specialization - "invalid result type" t)))) + (map (cut ##compiler#check-and-validate-type + <> + 'define-specialization) rtypes) spec) (list spec)))) @@ -1251,18 +1252,14 @@ (cond ((symbol? arg) (loop (cdr args) (cons arg anames) (cons '* atypes))) ((and (list? arg) (fx= 2 (length arg)) (symbol? (car arg))) - (let-values (((t pred pure) - (##compiler#validate-type - (##sys#strip-syntax (cadr arg)) - #f))) - (if t - (loop - (cdr args) - (cons (car arg) anames) - (cons t atypes)) - (syntax-error - 'define-specialization - "invalid argument type" arg head)))) + (loop + (cdr args) + (cons (car arg) anames) + (cons + (##compiler#check-and-validate-type + (cadr arg) + 'define-specialization) + atypes))) (else (syntax-error 'define-specialization "invalid argument syntax" arg head))))))))))))) @@ -1272,14 +1269,24 @@ (##sys#er-transformer (lambda (x r c) (##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1))) - (let ((var (gensym)) + (let ((val (memq #:compiling ##sys#features)) + (var (gensym)) (ln (get-line-number x))) `(##core#let ((,var ,(cadr x))) (##core#typecase ,ln ,var ; must be variable (see: CPS transform) ,@(map (lambda (clause) - (list (car clause) `(##core#begin ,@(cdr clause)))) + (let ((hd (##sys#strip-syntax (car clause)))) + (list + (if (eq? hd 'else) + 'else + (if val + (##compiler#check-and-validate-type + hd + 'compiler-typecase) + hd)) + `(##core#begin ,@(cdr clause))))) (cddr x)))))))) (##sys#extend-macro-environment @@ -1292,15 +1299,11 @@ (let ((name (##sys#strip-syntax (cadr x))) (%quote (r 'quote)) (t0 (##sys#strip-syntax (caddr x)))) - (let-values (((t pred pure) (##compiler#validate-type t0 name))) - (if t - `(##core#elaborationtimeonly - (##sys#put/restore! - (,%quote ,name) - (,%quote ##compiler#type-abbreviation) - (,%quote ,t))) - (syntax-error-hook 'define-type "invalid type" name t0))))))))) - + `(##core#elaborationtimeonly + (##sys#put/restore! + (,%quote ,name) + (,%quote ##compiler#type-abbreviation) + (,%quote ,(##compiler#check-and-validate-type t0 'define-type name)))))))))) ;; capture current macro env diff --git a/compiler-namespace.scm b/compiler-namespace.scm index edc9bb4..41dbaf1 100644 --- a/compiler-namespace.scm +++ b/compiler-namespace.scm @@ -47,6 +47,7 @@ canonicalize-begin-body canonicalize-expression check-and-open-input-file + check-and-validate-type check-signature chop-extension chop-separator diff --git a/compiler.scm b/compiler.scm index 68061e0..94d178d 100644 --- a/compiler.scm +++ b/compiler.scm @@ -538,7 +538,7 @@ ((##core#the) `(##core#the - ,(validate-type (##sys#strip-syntax (cadr x)) #f) + ,(##sys#strip-syntax (cadr x)) ,(caddr x) ,(walk (cadddr x) e se dest ldest h ln))) diff --git a/scrutinizer.scm b/scrutinizer.scm index 425278f..6e03660 100755 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -755,32 +755,30 @@ r (map (cut resolve <> typeenv) r))))))) ((##core#the) - (let-values (((t pred pure) (validate-type (first params) #f))) - (unless t - (quit "invalid type specification: ~s" (first params))) - (let ((rt (walk (first subs) e loc dest tail flow ctags))) - (cond ((eq? rt '*)) - ((null? rt) + (let ((t (first params)) + (rt (walk (first subs) e loc dest tail flow ctags))) + (cond ((eq? rt '*)) + ((null? rt) + (report + loc + (sprintf + "expression returns zero values but is declared to have a single result of type `~a'" + t))) + (else + (when (> (length rt) 1) (report loc + (sprintf + "expression returns ~a values but is declared to have a single result" + (length rt)))) + (when (and (second params) + (not (type<=? t (first rt)))) + ((if strict-variable-types report-error report-notice) + loc (sprintf - "expression returns zero values but is declared to have a single result of type `~a'" - t))) - (else - (when (> (length rt) 1) - (report - loc - (sprintf - "expression returns ~a values but is declared to have a single result" - (length rt)))) - (when (and (second params) - (not (type<=? t (first rt)))) - ((if strict-variable-types report-error report-notice) - loc - (sprintf - "expression returns a result of type `~a', but is declared to return `~a', which is not a subtype" - (first rt) t))))) - (list t)))) + "expression returns a result of type `~a', but is declared to return `~a', which is not a subtype" + (first rt) t))))) + (list t))) ((##core#typecase) (let* ((ts (walk (first subs) e loc #f #f flow ctags)) (trail0 trail) @@ -2072,6 +2070,11 @@ clean)))) (else (values #f #f #f))))) +(define (check-and-validate-type type loc #!optional name) + (let-values (((t pred pure) (validate-type (##sys#strip-syntax type) name))) + (or t + (error loc "invalid type specifier" type)))) + (define (install-specializations name specs) (define (fail spec) (error "invalid specialization format" spec name)) -- 1.7.0.4
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
