Hi all,

Here's a relatively simple fix for #1649 with tests.  Note that the patch
seems pretty big in support.scm, but it's mostly an indentation change
due to the added "if".  I didn't actually change the body of
foreign-type->scrutiny-type except for sticking an "if" in front.

I noticed that currently there's no way to have only argument conversion
or only return value conversion with define-foreign-type.  At first
glance, it looks like this assumption is not too deep.  We could try to
improve the situation by storing #f as the retconv/argconv slot of the
foreign type in these sitations.

On the other hand, to me it doesn't seem very useful to have conversion
only in one direction, so I think for 5.2 it's enough to have the fix as
attached.

Cheers,
Peter
From 78cc27a8c0518a109645d094c68065d027571e1e Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Fri, 29 Nov 2019 21:47:14 +0100
Subject: [PATCH] Don't infer types for foreign lambdas from foreign type with
 retconv/argconv

This is invalid, as shown by #1649.  Ideally we'd defer the type
inference of foreign types with retconv/argconv to the result of
scrutinizer's analysis of the retconv/argconv procedure's result, if
known.  To do so would be very tricky, as the way the types are
determined now is at macro-expansion time, which is before scrutiny.

So for now, we assign '* as the type if there's argconv or retconv.
---
 NEWS                      |   3 +
 support.scm               | 141 +++++++++++++++++++++-----------------
 tests/typematch-tests.scm |  24 +++++++
 3 files changed, 105 insertions(+), 63 deletions(-)

diff --git a/NEWS b/NEWS
index 477ffa40..0890e8fd 100644
--- a/NEWS
+++ b/NEWS
@@ -39,6 +39,9 @@
     (fixes #1440, thanks to "megane").
   - In some cases, rest argument lists do not need to be reified, which
     should make using optional arguments and case-lambda faster (#1623).
+  - Values from foreign types which have an argument or return value
+    converter are no longer inferred to have the Scheme type which
+    corresponds to the raw foreign type, which was incorrect (#1649).
 
 - Module system
   - Trying to export a foreign variable, define-inlined procedure or
diff --git a/support.scm b/support.scm
index e5eee630..0007acc4 100644
--- a/support.scm
+++ b/support.scm
@@ -1172,17 +1172,25 @@
 
 ;;; Compute foreign-type conversions:
 
+(define (foreign-type-result-converter t)
+  (and-let* (((symbol? t))
+	     (ft (lookup-foreign-type t))
+	     (retconv (vector-ref ft 2)) )
+    retconv))
+
+(define (foreign-type-argument-converter t)
+  (and-let* (((symbol? t))
+	     (ft (lookup-foreign-type t))
+	     (argconv (vector-ref ft 1)) )
+    argconv))
+
 (define (foreign-type-convert-result r t) ; Used only in compiler.scm
-  (or (and-let* (((symbol? t))
-		 (ft (lookup-foreign-type t)) 
-		 (retconv (vector-ref ft 2)) )
+  (or (and-let* ((retconv (foreign-type-result-converter t)))
 	(list retconv r) )
       r) )
 
 (define (foreign-type-convert-argument a t) ; Used only in compiler.scm
-  (or (and-let* (((symbol? t))
-		 (ft (lookup-foreign-type t))
-		 (argconv (vector-ref ft 1)) )
+  (or (and-let* ((argconv (foreign-type-argument-converter t)) )
 	(list argconv a) )
       a) )
 
@@ -1301,63 +1309,70 @@
 
 ;; Used in chicken-ffi-syntax.scm and scrutinizer.scm
 (define (foreign-type->scrutiny-type t mode) ; MODE = 'arg | 'result
-  (let ((ft (final-foreign-type t)))
-    (case ft
-      ((void) 'undefined)
-      ((char unsigned-char) 'char)
-      ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
-       'fixnum)
-      ((float double)
-       (case mode
-	 ((arg) 'number)
-	 (else 'float)))
-      ((scheme-pointer nonnull-scheme-pointer) '*)
-      ((blob) 
-       (case mode
-	 ((arg) '(or boolean blob))
-	 (else 'blob)))
-      ((nonnull-blob) 'blob)
-      ((pointer-vector) 
-       (case mode
-	 ((arg) '(or boolean pointer-vector))
-	 (else 'pointer-vector)))
-      ((nonnull-pointer-vector) 'pointer-vector)
-      ((u8vector u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector)
-       (case mode
-	 ((arg) `(or boolean (struct ,ft)))
-	 (else `(struct ,ft))))
-      ((nonnull-u8vector) '(struct u8vector))
-      ((nonnull-s8vector) '(struct s8vector))
-      ((nonnull-u16vector) '(struct u16vector))
-      ((nonnull-s16vector) '(struct s16vector))
-      ((nonnull-u32vector) '(struct u32vector))
-      ((nonnull-s32vector) '(struct s32vector))
-      ((nonnull-u64vector) '(struct u64vector))
-      ((nonnull-s64vector) '(struct s64vector))
-      ((nonnull-f32vector) '(struct f32vector))
-      ((nonnull-f64vector) '(struct f64vector))
-      ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer64
-		unsigned-long) 
-       'integer)
-      ((c-pointer)
-       '(or boolean pointer locative))
-      ((nonnull-c-pointer) 'pointer)
-      ((c-string c-string* unsigned-c-string unsigned-c-string*)
-       '(or boolean string))
-      ((c-string-list c-string-list*)
-       '(list-of string))
-      ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string)
-      ((symbol) 'symbol)
-      (else
-       (cond ((pair? t)
-	      (case (car t)
-		((ref pointer function c-pointer)
-		 '(or boolean pointer locative))
-		((const) (foreign-type->scrutiny-type (cadr t) mode))
-		((enum) 'integer)
-		((nonnull-pointer nonnull-c-pointer) 'pointer)
-		(else '*)))
-	     (else '*))))))
+  ;; If the foreign type has a converter, it can return a different
+  ;; type from the native type matching the foreign type (see #1649)
+  (if (or (and (eq? mode 'arg) (foreign-type-argument-converter t))
+	  (and (eq? mode 'result) (foreign-type-result-converter t)))
+      ;; Here we just punt on the type, but it would be better to
+      ;; find out the result type of the converter procedure.
+      '* 
+      (let ((ft (final-foreign-type t)))
+	(case ft
+	  ((void) 'undefined)
+	  ((char unsigned-char) 'char)
+	  ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
+	   'fixnum)
+	  ((float double)
+	   (case mode
+	     ((arg) 'number)
+	     (else 'float)))
+	  ((scheme-pointer nonnull-scheme-pointer) '*)
+	  ((blob) 
+	   (case mode
+	     ((arg) '(or boolean blob))
+	     (else 'blob)))
+	  ((nonnull-blob) 'blob)
+	  ((pointer-vector) 
+	   (case mode
+	     ((arg) '(or boolean pointer-vector))
+	     (else 'pointer-vector)))
+	  ((nonnull-pointer-vector) 'pointer-vector)
+	  ((u8vector u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector)
+	   (case mode
+	     ((arg) `(or boolean (struct ,ft)))
+	     (else `(struct ,ft))))
+	  ((nonnull-u8vector) '(struct u8vector))
+	  ((nonnull-s8vector) '(struct s8vector))
+	  ((nonnull-u16vector) '(struct u16vector))
+	  ((nonnull-s16vector) '(struct s16vector))
+	  ((nonnull-u32vector) '(struct u32vector))
+	  ((nonnull-s32vector) '(struct s32vector))
+	  ((nonnull-u64vector) '(struct u64vector))
+	  ((nonnull-s64vector) '(struct s64vector))
+	  ((nonnull-f32vector) '(struct f32vector))
+	  ((nonnull-f64vector) '(struct f64vector))
+	  ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer64
+		    unsigned-long) 
+	   'integer)
+	  ((c-pointer)
+	   '(or boolean pointer locative))
+	  ((nonnull-c-pointer) 'pointer)
+	  ((c-string c-string* unsigned-c-string unsigned-c-string*)
+	   '(or boolean string))
+	  ((c-string-list c-string-list*)
+	   '(list-of string))
+	  ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string)
+	  ((symbol) 'symbol)
+	  (else
+	   (cond ((pair? t)
+		  (case (car t)
+		    ((ref pointer function c-pointer)
+		     '(or boolean pointer locative))
+		    ((const) (foreign-type->scrutiny-type (cadr t) mode))
+		    ((enum) 'integer)
+		    ((nonnull-pointer nonnull-c-pointer) 'pointer)
+		    (else '*)))
+		 (else '*)))))))
 
 
 ;;; Scan expression-node for variable usage:
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index ac2d447c..59ba506c 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -427,4 +427,28 @@
 
 (infer true (= 3 (+ 1 2))) ; Constant folding should happen before / during scrutiny
 
+
+;; #1649; foreign types with retconv should not be inferred to have
+;; the foreign type's corresponding Scheme type, as the retconv may
+;; return a wildly different type.
+(define-foreign-type retconverted-foreign-int int identity ->string)
+(define-foreign-type argconverted-foreign-int int ->string)
+
+;; retconverted-type gets annotated with type (procedure () fixnum)
+;; 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)) )
+
+(let ((argconverted (foreign-lambda argconverted-foreign-int "rand")))
+  ;; Currently types with only argconvert get a retconvert as well,
+  ;; which is set to ##sys#values.  Ideally we should recognise this and
+  ;; know the type is unmodified.
+  ;(infer fixnum (argconverted))
+  (infer-not fixnum (argconverted)) )
+
+(let ((unconverted (foreign-lambda int "rand")))
+  (infer fixnum (unconverted)))
+
 (test-exit)
-- 
2.20.1

Attachment: signature.asc
Description: PGP signature

Reply via email to