~ chicken-core (chicken-5) e231be6676389285f60399cc71cad6f390e03e24
commit e231be6676389285f60399cc71cad6f390e03e24
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Apr 6 08:57:32 2011 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Apr 6 08:57:32 2011 -0400
-strict-types
diff --git a/batch-driver.scm b/batch-driver.scm
index dbd0e9e5..37f70793 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -259,6 +259,7 @@
(parentheses-synonyms #f)
(symbol-escape #f) )
(set! verbose-mode verbose)
+ (set! strict-variable-types (memq 'strict-types options))
(set! ##sys#read-error-with-line-number #t)
(set! ##sys#include-pathnames
(append (map chop-separator (collect-options 'include-path))
@@ -530,7 +531,7 @@
(load-inline-file ilf) )
ifs)))
- (when (or do-scrutinize do-specialize)
+ (when (or strict-variable-types do-scrutinize do-specialize)
;;XXX hardcoded database file name
(unless (memq 'ignore-repository options)
(load-type-database "types.db"))
diff --git a/c-platform.scm b/c-platform.scm
index 5b7d2b63..b5fcdb6c 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -91,6 +91,7 @@
no-procedure-checks-for-toplevel-bindings module
no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries
+ strict-types
lambda-lift ; OBSOLETE
setup-mode unboxing no-module-registration) )
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index de3869ad..c5fc3ecd 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -268,6 +268,7 @@
source-info->line
specialize-node!
standalone-executable
+ strict-variable-types
string->c-identifier
string->expr
stringify
diff --git a/compiler.scm b/compiler.scm
index 4d958fa6..e9123eda 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -334,6 +334,7 @@
(define compiler-syntax-enabled #t)
(define unchecked-specialized-arithmetic #f)
(define bootstrap-mode #f)
+(define struct-variable-types #f)
;;; These are here so that the backend can access them:
diff --git a/csc.scm b/csc.scm
index 16643dd2..fd91fa98 100644
--- a/csc.scm
+++ b/csc.scm
@@ -139,7 +139,7 @@
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
-emit-all-import-libraries -setup-mode -unboxing -no-elevation -no-module-registration
-no-procedure-checks-for-usual-bindings -module
- -specialize
+ -specialize -strict-types
-lambda-lift ; OBSOLETE
-no-procedure-checks-for-toplevel-bindings))
@@ -353,6 +353,7 @@ Usage: #{csc} FILENAME | OPTION ...
file
-S -scrutinize perform local flow analysis
-types FILENAME load additional type database
+ -strict-types assume variable do not change their type
Optimization options:
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 005d3419..f918d174 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -87,6 +87,7 @@
(define specialization-statistics '())
+
(define (scrutinize node db complain specialize)
(let ((blist '())
(safe-calls 0))
@@ -375,6 +376,9 @@
((match (car results1) (car results2))
(match-results (cdr results1) (cdr results2)))
(else #f)))
+ (define (compatible-types? t1 t2)
+ (or (type<=? t1 t2)
+ (type<=? t2 t1)))
(define (type<=? t1 t2)
(or (eq? t1 t2)
(memq t2 '(* undefined))
@@ -715,11 +719,19 @@
"assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
rt var type)
#t))
- (when (and b (eq? 'undefined (cdr b)))
- (set-cdr! b rt))
;;XXX we could set the ##compiler#type property here for hidden
;; globals that are only assigned once
(when b
+ (cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))
+ (strict-variable-types
+ (let ((ot (or (blist-type var flow) (cdr b))))
+ (unless (compatible-types? ot rt)
+ (report
+ loc
+ (sprintf
+ "variable `~a' of type `~a' was modified to a value of type `~a'"
+ var ot rt)
+ #t)))))
(set! blist (alist-cons (cons var (car flow)) rt blist)))
'(undefined)))
((##core#primitive ##core#inline_ref) '*)
@@ -742,7 +754,8 @@
(enforces (and pn (variable-mark pn '##compiler#enforce-argument-types)))
(pt (and pn (variable-mark pn '##compiler#predicate))))
(let ((r (call-result n args e loc params)))
- (invalidate-blist)
+ (unless strict-variable-types
+ (invalidate-blist))
(for-each
(lambda (arg argr)
(when (eq? '##core#variable (node-class arg))
diff --git a/support.scm b/support.scm
index ab0295b7..e9d20e86 100644
--- a/support.scm
+++ b/support.scm
@@ -1535,6 +1535,7 @@ Usage: chicken FILENAME OPTION ...
-no-lambda-info omit additional procedure-information
-scrutinize perform local flow analysis for static checks
-types FILENAME load additional type database
+ -strict-types assume variable do not change their type
-emit-type-file FILENAME write type-declaration information into file
Optimization options:
Trap