From 3cd4ee1c0dfbc012a8150f724cc70f923dbd1786 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 14 Feb 2013 15:43:36 -0700
Subject: [PATCH] ffi/unsafe: allow multiple values for a `(_fun ... ->
 _racket)' result

Closes PR 13496
---
 collects/ffi/unsafe.rkt                  | 36 +++++++++++++++---------
 collects/scribblings/foreign/types.scrbl | 12 ++++++--
 collects/tests/racket/foreign-test.rktl  |  4 +++
 3 files changed, 36 insertions(+), 16 deletions(-)

diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt
index 22ada8386b..cbee2e8cac 100644
--- a/collects/ffi/unsafe.rkt
+++ b/collects/ffi/unsafe.rkt
@@ -522,7 +522,7 @@
   (define ((t-n-e clause) type name expr)
     (let ([keys (custom-type->keys type err)])
       (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
-      (define (arg x . no-expr?)
+      (define (arg x . no-expr?) ;; can mutate `name'
         (define use-expr?
           (and (list? x) (= 2 (length x)) (identifier? (car x))))
         ;; when the current expr is not used with a (x => ...) form,
@@ -533,7 +533,9 @@
             (err "got an expression for a custom type that do not use it"
                  clause)
             (set! expr (void))))
-        (when use-expr? (set! x (with-renamer (car x) name (cadr x))))
+        (when use-expr?
+          (unless name (set! name (car (generate-temporaries #'(ret)))))
+          (set! x (with-renamer (car x) name (cadr x))))
         (cond [(getkey '1st) =>
                (lambda (v)
                  (if 1st-arg
@@ -551,8 +553,10 @@
         (set! type (getkey 'type))
         (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))])
         (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))])
-        (cond [(getkey 'pre ) => (lambda (x) (pre!  #`[#,name #,(arg x #t)]))])
-        (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])
+        (cond [(getkey 'pre ) => (lambda (x) (pre!  (let ([a (arg x #t)])
+                                                      #`[#,name #,a])))])
+        (cond [(getkey 'post) => (lambda (x) (post! (let ([a (arg x)])
+                                                      #`[#,name #,a])))])
         (cond [(getkey 'keywords)
                => (lambda (ks)
                     (for ([k+v (in-list ks)])
@@ -615,18 +619,17 @@
     ;; when processing the output type, only the post code matters
     (set! pre! (lambda (x) #f))
     (set! output
-          (let ([temp (car (generate-temporaries #'(ret)))]
-                [t-n-e (t-n-e output-type)])
+          (let ([t-n-e (t-n-e output-type)])
             (syntax-case* output-type (: =) id=?
               [(name : type) (t-n-e #'type #'name output-expr)]
               [(type = expr) (if output-expr
                                (err "extraneous output expression" #'expr)
-                               (t-n-e #'type temp #'expr))]
+                               (t-n-e #'type #f #'expr))]
               [(name : type = expr)
                              (if output-expr
                                (err "extraneous output expression" #'expr)
                                (t-n-e #'type #'name #'expr))]
-              [type          (t-n-e #'type temp output-expr)])))
+              [type          (t-n-e #'type #f output-expr)])))
     (let ([make-cprocedure
            (lambda (wrapper)
              #`(_cprocedure* (list #,@(filter-map car inputs))
@@ -647,7 +650,7 @@
                                 inputs))]
                [output-expr
                 (let ([o (caddr output)])
-                  (or (and (not (void? o)) o) (cadr output)))]
+                  (and (not (void? o)) o))]
                [args
                 (filter-map (lambda (i)
                               (and (caddr i)
@@ -661,10 +664,17 @@
                        (lambda #,input-names
                          (let* (#,@args
                                 #,@bind
-                                #,@pre
-                                [#,(cadr output) (ffi #,@ffi-args)]
-                                #,@post)
-                           #,output-expr)))]
+                                #,@pre)
+                           #,(if (or output-expr
+                                     (cadr output))
+                                 (let ([res (or (cadr output)
+                                                (car (generate-temporaries #'(ret))))])
+                                   #`(let* ([#,res (ffi #,@ffi-args)]
+                                            #,@post)
+                                       #,(or output-expr res)))
+                                 #`(begin0
+                                    (ffi #,@ffi-args)
+                                    #,@post)))))]
                ;; if there is a string 'ffi-name property, use it as a name
                [body (let ([n (cond [(syntax-property stx 'ffi-name)
                                      => syntax->datum]
diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl
index f2daacf876..f24bd1c6d1 100644
--- a/collects/scribblings/foreign/types.scrbl
+++ b/collects/scribblings/foreign/types.scrbl
@@ -356,9 +356,15 @@ generates @racket[#f] for a cpointer generated via the
 )]{
 
 A type that can be used with any Racket object; it corresponds to the
-@cpp{Scheme_Object*} type of Racket's C API (see
-@|InsideRacket|).  It is useful only for libraries that are aware of
-Racket's C API.}
+@cpp{Scheme_Object*} type of Racket's C API (see @|InsideRacket|). The
+@racket[_racket] or @racket[_scheme] type is useful only for libraries
+that are aware of Racket's C API.
+
+As a result type with a function type, @racket[_racket] or
+@racket[_scheme] permits multiple values, but multiple values are not
+allowed in combination with a true value for
+@racket[#:in-original-place?] or @racket[#:async-apply] in
+@racket[_cprocedure] or @racket[_fun].}
 
 
 @defthing[_fpointer ctype?]{
diff --git a/collects/tests/racket/foreign-test.rktl b/collects/tests/racket/foreign-test.rktl
index 4814dc1762..135c5a56c8 100644
--- a/collects/tests/racket/foreign-test.rktl
+++ b/collects/tests/racket/foreign-test.rktl
@@ -477,6 +477,10 @@
 
 (delete-test-files)
 
+(let ()
+  (define _values (get-ffi-obj 'scheme_values #f (_fun _int (_list i _racket) -> _racket)))
+  (test-values '(1 "b" three) (lambda () (_values 3 (list 1 "b" 'three)))))
+
 (report-errs)
 
 #| --- ignore everything below ---