From e90e587a91c97ad423d979f4778da29207b4c7af Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 7 Mar 2016 16:11:46 -0600
Subject: [PATCH] Generalize `procedure-result-arity` to work on reduced-arity
 procedures.

---
 pkgs/racket-test-core/tests/racket/function.rktl |  9 +++++++++
 racket/src/racket/src/fun.c                      | 15 +++++++++++----
 2 files changed, 20 insertions(+), 4 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/function.rktl b/pkgs/racket-test-core/tests/racket/function.rktl
index 4175b3b284..bc96e5e9c2 100644
--- a/pkgs/racket-test-core/tests/racket/function.rktl
+++ b/pkgs/racket-test-core/tests/racket/function.rktl
@@ -110,7 +110,9 @@
 
 (test 1 procedure-result-arity car)
 (test 1 procedure-result-arity list)
+(test 1 procedure-result-arity (procedure-reduce-arity car 1))
 (test (arity-at-least 0) procedure-result-arity values)
+(test (arity-at-least 0) procedure-result-arity (procedure-reduce-arity values 1))
 (test (arity-at-least 0) procedure-result-arity call/cc)
 (let ()
   (struct s (x))
@@ -124,6 +126,13 @@
         (if (= 0 (random 1))
             1
             (values 1 2))))
+(test #f procedure-result-arity
+      (procedure-reduce-arity
+       (λ ()
+         (if (= 0 (random 1))
+             1
+             (values 1 2)))
+       0))
 (err/rt-test (procedure-result-arity 1) exn:fail?)
 (test 1 procedure-result-arity (chaperone-procedure car values))
 (test 1 procedure-result-arity (impersonate-procedure car (λ (x) 1)))
diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c
index 2f9ef1414a..201c06e03f 100644
--- a/racket/src/racket/src/fun.c
+++ b/racket/src/racket/src/fun.c
@@ -2909,7 +2909,10 @@ static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
 
   /* Struct procedures could be keyword-accepting and that
      requires additional complication; defer for now */
-  if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)) {
+  if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)
+      /* Structs corresponding to reduced-arity procedures are ok, though.
+         Their result arity is just that of the underlying procedure. */
+      && !scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
     return scheme_false;
   }
 
@@ -2939,6 +2942,9 @@ static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
       return scheme_make_arity(p->minr, p->maxr);
     }
     return scheme_make_integer(1);
+  } else if (SCHEME_STRUCTP(o)
+             && scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
+    return ((Scheme_Structure *)o)->slots[4];
   } else if (!SCHEME_PROCP(o)) {
     scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv);
     return NULL;
@@ -3132,7 +3138,7 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
     scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
                                                                NULL,
                                                                (Scheme_Object *)insp,
-                                                               4, 0,
+                                                               5, 0,
                                                                scheme_false,
                                                                scheme_null,
                                                                scheme_make_integer(0),
@@ -3142,7 +3148,7 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
 
 static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name, Scheme_Object *is_meth)
 {
-  Scheme_Object *a[4];
+  Scheme_Object *a[5];
   
   if (SCHEME_STRUCTP(proc)
       && scheme_is_struct_instance(scheme_reduced_procedure_struct, proc)) {
@@ -3158,8 +3164,9 @@ static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty,
   a[1] = aty;
   a[2] = (name ? name : scheme_false);
   a[3] = (is_meth ? is_meth : scheme_false);
+  a[4] = procedure_result_arity(1, &proc);
 
-  return scheme_make_struct_instance(scheme_reduced_procedure_struct, 4, a);
+  return scheme_make_struct_instance(scheme_reduced_procedure_struct, 5, a);
 }
 
 static int is_subarity(Scheme_Object *req, Scheme_Object *orig, int req_delta)