~ chicken-core (chicken-5) 8d038d86c17ef59c0d61697966dc7a32fbf56d15

commit 8d038d86c17ef59c0d61697966dc7a32fbf56d15
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Oct 9 07:08:59 2014 +1300
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Oct 11 14:35:53 2014 +0200

    Avoid invalid specializations for multi-valued foreign-primitives
    
    The foreign-primitive form may return multiple values with the C_values
    function, but its expansion is always declared to return a (single)
    undefined value. This triggers invalid ##sys#c-w-v specializations for
    single-valued producers where multiple values may in fact result.
    
    This fixes that declaration so that multiple values are expected when no
    return type is specified.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
    
    Conflicts:
            chicken-ffi-syntax.scm

diff --git a/NEWS b/NEWS
index 16094661..227fefba 100644
--- a/NEWS
+++ b/NEWS
@@ -67,6 +67,8 @@
 - Foreign function interface
   - The foreign type specifier "scheme-pointer" now accepts an optional
     C pointer type (thanks to Moritz Heidkamp and Kristian Lein-Mathisen).
+  - Type hinting for foreign-primitives now allows returning multiple
+    values when no return type has been specified.
 
 - Build system
   - MANDIR was renamed to MAN1DIR and TOPMANDIR was renamed to MANDIR
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index af02739a..d3fc79b9 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -213,13 +213,15 @@
   (lambda (form r c)
     (##sys#check-syntax 'foreign-primitive form '(_ _ . _))
     (let* ((hasrtype (and (pair? (cddr form)) (not (string? (caddr form)))))
-	   (rtype (or (and hasrtype (##sys#strip-syntax (cadr form))) 'void))
+	   (rtype (and hasrtype (##sys#strip-syntax (cadr form))))
 	   (args (##sys#strip-syntax (if hasrtype (caddr form) (cadr form))))
 	   (argtypes (map car args)))
       `(##core#the (procedure
 		    ,(map (cut chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
 			  argtypes)
-		    ,(chicken.compiler.support#foreign-type->scrutiny-type rtype 'result))
+		    ,@(if (not rtype)
+			  '* ; special case for C_values(...)
+			  (list (chicken.compiler.support#foreign-type->scrutiny-type rtype 'result))))
 		   #f
 		   (##core#foreign-primitive ,@(cdr form)))))))
 
diff --git a/manual/Accessing external objects b/manual/Accessing external objects
index 2fcec623..23107026 100644
--- a/manual/Accessing external objects	
+++ b/manual/Accessing external objects	
@@ -167,13 +167,13 @@ function to call Scheme functions and allocate Scheme data-objects. See [[Callba
 
 <macro>(foreign-primitive [RETURNTYPE] ((ARGTYPE VARIABLE) ...) STRING ...)</macro>
 
-This is also similar to {{foreign-lambda*}} but the code will be executed
-in a ''primitive'' CPS context, which means it will not actually return, but
-call its continuation on exit. This means that code inside this form may
-allocate Scheme data on the C stack (the ''nursery'') with {{C_alloc}}
-(see below). If the {{RETURNTYPE}} is omitted it defaults to {{void}}.
-You can return multiple values inside the body of the {{foreign-primitive}}
-form by calling this C function:
+This is also similar to {{foreign-lambda*}} but the code will be
+executed in a ''primitive'' CPS context, which means it will not
+actually return, but call its continuation on exit. This means that code
+inside this form may allocate Scheme data on the C stack (the
+''nursery'') with {{C_alloc}} (see below). You can return multiple
+values inside the body of the {{foreign-primitive}} form by calling this
+C function:
 
 <enscript highlight=scheme>
 C_values(N + 2, C_SCHEME_UNDEFINED, C_k, X1, ...)
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 37e8d6bb..344e4451 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -46,5 +46,14 @@ return n;}
 
 (assert (null? (the (or undefined *) (list))))
 
+;; Ensure a foreign-primitive returning multiple values with C_values()
+;; isn't specialized to a single result.
+(let ((result (receive ((foreign-primitive ()
+			  "C_values(4,"
+			  "         C_SCHEME_UNDEFINED,"
+			  "         C_k,"
+			  "         C_fix(1),"
+			  "         C_fix(2));")))))
+  (assert (equal? '(1 2) result)))
 
 )