~ chicken-core (chicken-5) 1f56f3ad6bf20ea910d85bed45b4d6c304973dc5
commit 1f56f3ad6bf20ea910d85bed45b4d6c304973dc5
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Oct 13 10:47:23 2011 +0200
Commit: Christian Kellermann <ck@emlix.com>
CommitDate: Thu Oct 20 13:48:23 2011 +0200
##core#type makes subtype-check optional; quit compile when type-mismatches in strict mode
Signed-off-by: Christian Kellermann <ck@emlix.com>
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 6dd98e67..687c9587 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -174,7 +174,7 @@
(##core#the ,(##compiler#foreign-type->scrutiny-type
(##sys#strip-syntax (caddr form))
'result)
- ,tmp) ) ) ) ) )
+ #f ,tmp) ) ) ) ) )
;;; Include foreign code fragments
@@ -217,6 +217,7 @@
`(##core#the (procedure
,(map (cut ##compiler#foreign-type->scrutiny-type <> 'arg) argtypes)
,(##compiler#foreign-type->scrutiny-type rtype 'result))
+ #f
(##core#foreign-primitive ,@(cdr form)))))))
(##sys#extend-macro-environment
@@ -230,6 +231,7 @@
(##sys#strip-syntax (cdddr form)))
,(##compiler#foreign-type->scrutiny-type
(##sys#strip-syntax (cadr form)) 'result))
+ #f
(##core#foreign-lambda ,@(cdr form))))))
(##sys#extend-macro-environment
@@ -243,6 +245,7 @@
(##sys#strip-syntax (caddr form)))
,(##compiler#foreign-type->scrutiny-type
(##sys#strip-syntax (cadr form)) 'result))
+ #f
(##core#foreign-lambda* ,@(cdr form))))))
(##sys#extend-macro-environment
@@ -256,6 +259,7 @@
(##sys#strip-syntax (cdddr form)))
,(##compiler#foreign-type->scrutiny-type
(##sys#strip-syntax (cadr form)) 'result))
+ #f
(##core#foreign-safe-lambda ,@(cdr form))))))
(##sys#extend-macro-environment
@@ -269,6 +273,7 @@
(##sys#strip-syntax (caddr form)))
,(##compiler#foreign-type->scrutiny-type
(##sys#strip-syntax (cadr form)) 'result))
+ #f
(##core#foreign-safe-lambda* ,@(cdr form))))))
(##sys#extend-macro-environment
@@ -285,7 +290,7 @@
(##compiler#foreign-type-declaration t ""))))
`(##core#begin
(##core#define-foreign-variable ,tmp size_t ,(string-append "sizeof(" decl ")"))
- (##core#the fixnum ,tmp))))))
+ (##core#the fixnum #f ,tmp))))))
(##sys#macro-subset me0)))
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 14c98be4..7c4ab185 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1185,14 +1185,14 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'the x '(_ _ _))
- `(##core#the ,(##sys#strip-syntax (cadr x)) ,(caddr x)))))
+ `(##core#the ,(##sys#strip-syntax (cadr x)) #t ,(caddr x)))))
(##sys#extend-macro-environment
'assume '()
(##sys#er-transformer
(syntax-rules ()
((_ ((var type) ...) body ...)
- (let ((var (##core#the type var)) ...) body ...)))))
+ (let ((var (##core#the type #t var)) ...) body ...)))))
(##sys#extend-macro-environment
'define-specialization '()
@@ -1245,7 +1245,7 @@
(##core#declare (inline ,alias) (hide ,alias))
(,%define (,alias ,@anames)
(##core#let ,(map (lambda (an at)
- (list an `(##core#the ,at ,an)))
+ (list an `(##core#the ,at #t ,an)))
anames atypes)
,body)))))
(else
diff --git a/compiler.scm b/compiler.scm
index 3b2a03bb..cb9b2479 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -146,7 +146,7 @@
; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
; (##core#let-module-alias ((<alias> <name>) ...) <body>)
-; (##core#the <type> <exp>)
+; (##core#the <type> <strict?> <exp>)
; (##core#typecase <exp> (<type> <body>) ... [(else <body>)])
; (<exp> {<exp>})
@@ -174,7 +174,7 @@
; [##core#return <exp>]
; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
-; [##core#the {<type>} <exp>]
+; [##core#the {<type> <strict>} <exp>]
; [##core#typecase {(<type> ...)} <exp> <body1> ... [<elsebody>]]
; - Closure converted/prepared language:
@@ -553,7 +553,8 @@
((##core#the)
`(##core#the
,(##sys#strip-syntax (cadr x))
- ,(walk (caddr x) e se dest ldest h)))
+ ,(caddr x)
+ ,(walk (cadddr x) e se dest ldest h)))
((##core#typecase)
`(##core#typecase
diff --git a/eval.scm b/eval.scm
index d0b27eeb..0ad85b40 100644
--- a/eval.scm
+++ b/eval.scm
@@ -704,7 +704,7 @@
(compile-call (cdr x) e tf cntr se) ]
((##core#the)
- (compile (caddr x) e h tf cntr se))
+ (compile (cadddr x) e h tf cntr se))
((##core#typecase)
;; drops exp and requires "else" clause
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6d7bc972..674e54d2 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -123,6 +123,7 @@
(aliased '())
(noreturn #f)
(dropped-branches 0)
+ (errors #f)
(safe-calls 0))
(define (constant-result lit)
@@ -242,6 +243,12 @@
(warning
(conc (location-name loc) desc))))
+ (define (report-error loc desc #!optional (show complain))
+ (when show
+ (warning
+ (conc (location-name loc) desc)))
+ (set! errors #t))
+
(define (location-name loc)
(define (lname loc1)
(if loc1
@@ -597,8 +604,7 @@
(when (and type (not b)
(not (eq? type 'deprecated))
(not (match-types type rt typeenv)))
- ;;XXX make this an error with strict-types?
- (report
+ ((if strict-variable-types report-error report)
loc
(sprintf
"assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
@@ -752,8 +758,9 @@
(sprintf
"expression returns ~a values but is declared to have a single result"
(length rt))))
- (unless (type<=? t (first rt))
- (report-notice
+ (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"
@@ -800,6 +807,8 @@
(debugging 'x "safe calls" safe-calls)) ;XXX use 'o
(when (positive? dropped-branches)
(debugging 'x "dropped branches" dropped-branches)) ;XXX use 'o
+ (when errors
+ (quit "some variable types do not satisfy strictness"))
rn)))
@@ -2124,7 +2133,7 @@
(and (eq? 'quote (node-class index))
(let ((val (first (node-parameters index))))
(and (fixnum? val)
- (>= val 0) (< val (length (cdr arg1))) ;XXX could warn on failure
+ (>= val 0) (< val (length (cdr arg1))) ;XXX could warn on failure (but needs location)
(list (list-ref (cdr arg1) val))))))))
rtypes))
(define-special-case vector-ref vector-ref-result-type)
diff --git a/support.scm b/support.scm
index d2444b8f..921b97a6 100644
--- a/support.scm
+++ b/support.scm
@@ -505,7 +505,9 @@
((lambda ##core#lambda)
(make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
((##core#the)
- (make-node '##core#the (list (cadr x)) (list (walk (caddr x)))))
+ (make-node '##core#the
+ (list (second x) (third x))
+ (list (walk (fourth x)))))
((##core#typecase)
;; clause-head is already stripped
(let loop ((cls (cddr x)) (types '()) (exps (list (walk (cadr x)))))
Trap