~ chicken-core (chicken-5) 30b2e4ca0b20651e88d79e5d757c93d22487acc7
commit 30b2e4ca0b20651e88d79e5d757c93d22487acc7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Aug 15 21:34:01 2012 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Mon Aug 20 09:58:11 2012 +0200
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.
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 4c1161b8..c8f0f632 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 edc9bb43..41dbaf12 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 68061e09..94d178de 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 425278f6..6e036600 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))
Trap