[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] [PATCH] validate types in compiler-typecase
|
From: |
Felix |
|
Subject: |
Re: [Chicken-hackers] [PATCH] validate types in compiler-typecase |
|
Date: |
Sun, 19 Aug 2012 01:54:04 +0200 (CEST) |
> * felix winkelmann <address@hidden> [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 <address@hidden>
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