chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] [PATCH] subtype-check for "the" forms


From: Felix
Subject: [Chicken-hackers] [PATCH] subtype-check for "the" forms
Date: Thu, 20 Oct 2011 13:37:09 +0200 (CEST)

The attached patch disables the subtype-check for "the" forms
generated for FFI bindings (these can sometimes fail and produce
misleading warnings - the reason for this is that the generated stub
code carries not enough hints for the flow-analysis done inside the
scrutinizer). Moreover failed subtype-checks (for all other cases than
these FFI stubs) abort compilation if in strict-types mode.


cheers,
felix
commit e42a47c6c5c0708d21a1021c040508a8afc12fe9
Author: felix <address@hidden>
Date:   Thu Oct 13 10:47:23 2011 +0200

    ##core#type makes subtype-check optional; quit compile when type-mismatches 
in strict mode

diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 6dd98e6..687c958 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 14c98be..7c4ab18 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 3b2a03b..cb9b247 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 d0b27ee..0ad85b4 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 6d7bc97..674e54d 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 d2444b8..921b97a 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)))))

reply via email to

[Prev in Thread] Current Thread [Next in Thread]