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
signature.asc
Description: PGP signature
