~ chicken-core (chicken-5) 57641c946030cc387f8194f72c298f4487e4e934

commit 57641c946030cc387f8194f72c298f4487e4e934
Author:     megane <meganeka@gmail.com>
AuthorDate: Sun Dec 1 12:59:26 2019 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Fri Dec 27 10:45:39 2019 -0600

    Let scrutinizer infer types for foreign types with retconv/argconv given
    
    Not doing any annotation gives the scrutinizer a change to infer the
    reconverted arguments. Which it in many cases can do.
    
    For example this:
    
      (define-foreign-type retconverted-foreign-int int identity ->string)
      (foreign-lambda retconverted-foreign-int "rand")
    
    Gets converted to something like this:
    
      (set! g14 chicken.string#->string)
      (lambda () (g14 (##core#inline stub23 (##core#undefined))
    
    Which the scrutinizer can handle.
    
     * chicken-ffi-syntax.scm (annotate-foreign-procedure): Don't annotate
       if scrutinizer can infer types
    
       Ideally we could drop the annotation here completely if
       create-foreign-stub just annotated the return type of the stub call:
    
         (##core#inline stub25 (##core#undefined))
         =>
         (the fixnum (##core#inline stub25 (##core#undefined)))
    
       Generally the scrutinizer can infer the argument types if they are
       converted by enforcing functions like this:
    
         (lambda (int2730)
           (##core#inline
            stub28
            (##core#undefined)
            (##sys#foreign-fixnum-argument int2730)))
         =>
         (fixnum -> *)
    
     * tests/typematch-tests.scm: Expect more specific type now
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index b6ec4d5b..c78d0934 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -214,16 +214,32 @@
 ;;; Aliases for internal forms
 
 (define (annotate-foreign-procedure e argtypes rtype)
-  `(##core#the
-    (procedure ,(map (cut chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
-		     (chicken.syntax#strip-syntax argtypes))
-	       ,@(if rtype
-		     (list (chicken.compiler.support#foreign-type->scrutiny-type
-			    (chicken.syntax#strip-syntax rtype) 'result))
-		     ;; special case for C_values(...). Only triggered by foreign-primitive.
-		     '*))
-    #f
-    ,e))
+  (let ((scrut-atypes (map (cut chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
+			   (chicken.syntax#strip-syntax argtypes)))
+	(scrut-rtype (and rtype
+			  (chicken.compiler.support#foreign-type->scrutiny-type
+			   (chicken.syntax#strip-syntax rtype) 'result))))
+    ;; Don't add type annotation if the scrutinizer can infer the same
+    ;; or better.
+    ;;
+    ;; At least these cases should work:
+    ;;
+    ;;   (-> <some-known-type>)	=> annotate
+    ;;   (-> *)			=> no annotation
+    ;;   (* ... -> *)		=> no annotation
+    ;;
+    (if (and (or (not rtype) (eq? scrut-rtype '*))
+	     (every (cut eq? '* <>) scrut-atypes))
+	e
+	`(##core#the
+	  (procedure ,scrut-atypes
+		     ,@(if rtype
+			   (list scrut-rtype)
+			   ;; Special case for C_values(...). Only
+			   ;; triggered by foreign-primitive.
+			   '*))
+	  #f
+	  ,e))))
 
 (##sys#extend-macro-environment
  'define-foreign-type
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 59ba506c..42a97ac9 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -438,8 +438,7 @@
 ;; when the return type should be whatever the retconvert argument
 ;; to define-foreign-type returns (string in this case)
 (let ((retconverted (foreign-lambda retconverted-foreign-int "rand")))
-  (infer-not fixnum (retconverted))
-  (infer-not integer (retconverted)) )
+  (infer string (retconverted)))
 
 (let ((argconverted (foreign-lambda argconverted-foreign-int "rand")))
   ;; Currently types with only argconvert get a retconvert as well,