From 2270513c277ad26a6c2c7113cf74fa4d8ae38df4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 17 Dec 2019 17:13:07 -0700
Subject: [PATCH] cs: fix `procedure-extract-target` for applicable struct
 result

---
 pkgs/racket-test-core/tests/racket/procs.rktl | 22 +++++++++++++++++
 racket/src/cs/rumble/procedure.ss             | 24 ++++++++++++-------
 2 files changed, 37 insertions(+), 9 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/procs.rktl b/pkgs/racket-test-core/tests/racket/procs.rktl
index 3b804af04a..9b68df627a 100644
--- a/pkgs/racket-test-core/tests/racket/procs.rktl
+++ b/pkgs/racket-test-core/tests/racket/procs.rktl
@@ -472,6 +472,28 @@
 (err/rt-test (procedure-reduce-keyword-arity void 1 null '(#:b #:a))
              (lambda (exn) (regexp-match #rx"position: 4th" (exn-message exn))))
 
+
+;; ----------------------------------------
+;; Check `procedure-extract-target`
+
+(let ()
+  (struct p (v)
+    #:property prop:procedure 0)
+
+  (define (f x [y 0]) x)
+
+  (define pf (p f))
+  (define ppf (p pf))
+
+  (test #t eq? f (procedure-extract-target pf))
+  (test #t eq? pf (procedure-extract-target ppf))
+
+  (define r (procedure-reduce-arity f 1))
+  (test #t not (procedure-extract-target r))
+
+  (define rpf (procedure-reduce-arity pf 1))
+  (test #t not (procedure-extract-target rpf)))
+
 ;; ----------------------------------------
 ;; Check mutation of direct-called keyword procedure
 
diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss
index 20653c493b..68e037f97c 100644
--- a/racket/src/cs/rumble/procedure.ss
+++ b/racket/src/cs/rumble/procedure.ss
@@ -257,15 +257,21 @@
 (define/who (procedure-extract-target f)
   (cond
    [(record? f)
-    (let* ([rtd (record-rtd f)]
-           [v (struct-property-ref prop:procedure rtd #f)])
-      (cond
-       [(fixnum? v)
-        (let ([v (unsafe-struct-ref f v)])
-          (and (#%procedure? v) v))]
-       [else
-        (check who procedure? f)
-        #f]))]
+    (cond
+     [(or (reduced-arity-procedure? f)
+          (named-procedure? f)
+          (method-procedure? f))
+      #f]
+     [else
+      (let* ([rtd (record-rtd f)]
+             [v (struct-property-ref prop:procedure rtd #f)])
+        (cond
+         [(fixnum? v)
+          (let ([v (unsafe-struct-ref f v)])
+            (and (procedure? v) v))]
+         [else
+          (check who procedure? f)
+          #f]))])]
    [else
     (check who procedure? f)
     #f]))