add "alias" and "converted-arguments-variant" properties

The properties appear in the inlining expansion of an application
of a keyword-accepting function, and they're mainly intended for
use by Typed Racket.

The property keys are hidden, so that the property value can be
trusted as originating from `racket/base'. The accessor functions are
`syntax-procedure-alias-property' and
`syntax-procedure-converted-arguments-property' from
`racket/keyword-transform'.

collects/racket/keyword-transform.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require (for-template "private/kw.rkt"))
+(provide syntax-procedure-alias-property
+         syntax-procedure-converted-arguments-property)
+

collects/racket/private/kw.rkt

@@ -24,7 +24,9 @@
              new:procedure-rename
              new:chaperone-procedure
              new:impersonate-procedure
-             (for-syntax kw-expander? kw-expander-impl kw-expander-proc))
+             (for-syntax kw-expander? kw-expander-impl kw-expander-proc
+                         syntax-procedure-alias-property 
+                         syntax-procedure-converted-arguments-property))
 
   ;; ----------------------------------------
 
@@ -967,6 +969,16 @@
   (define-for-syntax kw-expander-impl (make-struct-field-accessor kw-expander-ref 1 'impl))
   (define-for-syntax kw-expander-proc (make-struct-field-accessor kw-expander-ref 2 'proc))
 
+  (define-for-syntax kw-alias-of (gensym 'alias-of))
+  (define-for-syntax kw-converted-arguments-variant-of (gensym 'converted-arguments-variant-of))
+
+  (define-for-syntax (syntax-procedure-alias-property stx)
+    (unless (syntax? stx) (raise-type-error 'syntax-procedure-alias "syntax" stx))
+    (syntax-property stx kw-alias-of))
+  (define-for-syntax (syntax-procedure-converted-arguments-property stx) 
+    (unless (syntax? stx) (raise-type-error 'syntax-procedure-converted-arguments "syntax" stx))
+    (syntax-property stx kw-converted-arguments-variant-of))
+
   (define-for-syntax (make-keyword-syntax get-ids n-req n-opt rest? req-kws all-kws)
     (make-kw-expander
      (lambda (stx)
@@ -994,7 +1006,15 @@
                                       ""))
                                 msg
                                 (syntax-e #'self))
-                        (current-continuation-marks)))))])
+                        (current-continuation-marks)))))]
+                [impl-id/prop
+                 (syntax-property impl-id kw-converted-arguments-variant-of 
+                                  (cons (syntax-taint (syntax-local-introduce #'self))
+                                        (syntax-taint (syntax-local-introduce impl-id))))]
+                [wrap-id/prop
+                 (syntax-property wrap-id kw-alias-of 
+                                  (cons (syntax-taint (syntax-local-introduce #'self))
+                                        (syntax-taint (syntax-local-introduce wrap-id))))])
             (if (free-identifier=? #'new-app (datum->syntax stx '#%app))
                 (parse-app (datum->syntax #f (cons #'new-app stx) stx)
                            (lambda (n)
@@ -1053,7 +1073,7 @@
                                        (lambda (args)
                                          (quasisyntax/loc stx
                                            (if (variable-reference-constant? (#%variable-reference #,wrap-id))
-                                               (#,impl-id 
+                                               (#,impl-id/prop
                                                 ;; keyword arguments:
                                                 #,@(let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws])
                                                      (cond
@@ -1097,10 +1117,12 @@
                                                        null))
                                                #,(if lifted?
                                                      orig
-                                                     (quasisyntax/loc stx (#%app #,wrap-id . #,args)))))))))
+                                                     (quasisyntax/loc stx (#%app #,wrap-id/prop . #,args)))))))))
                                 orig))))
-                (datum->syntax stx (cons wrap-id #'(arg ...)) stx stx)))]
+                (datum->syntax stx (cons wrap-id/prop #'(arg ...)) stx stx)))]
-         [_ wrap-id]))
+         [self
+          (syntax-property wrap-id kw-alias-of (cons (syntax-taint (syntax-local-introduce #'self))
+                                                     (syntax-taint (syntax-local-introduce wrap-id))))]))
      (lambda () (define-values (impl-id wrap-id) (get-ids)) impl-id)
      (lambda () (define-values (impl-id wrap-id) (get-ids)) wrap-id)))
 

collects/scribblings/reference/stx-trans.scrbl

@@ -1126,6 +1126,38 @@ A structure representing a single imported identifier:
 For backward compatibility only; returns a procedure that returns its
 first argument.}
 
+@; ----------------------------------------------------------------------
+
+@section[#:tag "keyword-trans"]{Keyword-Argument Conversion Introspection}
+
+@note-lib-only[racket/keyword-transform]
+
+@deftogether[(
+@defproc[(syntax-procedure-alias-property [stx syntax?])
+         (or/c #f 
+               (letrec ([val? (recursive-contract
+                               (or/c (cons/c identifier? identifier?)
+                                     (cons/c val? val?)))])
+                 val?))]
+@defproc[(syntax-procedure-converted-arguments-property [stx syntax?])
+         (or/c #f 
+               (letrec ([val? (recursive-contract
+                               (or/c (cons/c identifier? identifier?)
+                                     (cons/c val? val?)))])
+                 val?))]
+)]{
+
+At expansion time, reports the value of a syntax property that can be
+attached to an identifier by the expansion of a keyword-application
+form during the same expansion time. See @racket[lambda] for more
+information about the property.
+
+The property value is normally a pair consisting of the original
+identifier and an identifier that appears in the
+expansion. Property-value merging via @racket[syntax-track-origin] can make
+the value a pair of such values, and so on.}
+
+
 @; ----------------------------------------------------------------------
 
 @close-eval[stx-eval]

collects/scribblings/reference/syntax.scrbl

@@ -7,6 +7,7 @@
                      racket/require
                      (only-in racket/provide-transform
                               make-provide-transformer)
+                     racket/keyword-transform
                      racket/provide-syntax
                      racket/provide
                      racket/package
@@ -1708,7 +1709,29 @@ will hide the first argument, if one was provided. (Hiding the first
 argument is useful when the procedure implements a method, where the
 first argument is implicit in the original source). The property
 affects only the format of @racket[exn:fail:contract:arity]
-exceptions, not the result of @racket[procedure-arity].}
+exceptions, not the result of @racket[procedure-arity].
+
+When a keyword-accepting procedure is bound to an identifier in
+certain ways, and when the identifier is used in the function position
+of an application form, then the application form may be expanded in
+such a way that the original binding is obscured as the target of the
+application. To help expose the connection between the function
+application and function declaration, an identifier in the expansion
+of the function application is tagged with a @tech{syntax property}
+accessible via @racket[syntax-procedure-alias-property] if it is effectively an alias
+for the original identifier. An identifier in the expansion is tagged with a
+a @tech{syntax property} accessible via @racket[syntax-procedure-converted-arguments-property] if it
+is like the original identifier except that the arguments are converted to a
+flattened form: keyword arguments, required by-position arguments,
+by-position optional arguments, and rest arguments---all as required,
+by-position arguments; the keyword arguments are sorted by keyword
+name, each optional keyword argument is preceded by a boolean to
+indicate whether a value is provided, and @racket[#f] is used for an
+optional keyword argument whose value is not provided; optional
+by-position arguments include @racket[#f] for each non-provided
+argument, and then the sequence of optional-argument values is
+followed by a parallel sequence of booleans to indicate whether each
+optional-argument value was provided.}
 
 
 @defform/subs[(case-lambda [formals body ...+] ...)

collects/tests/racket/syntax.rktl

@@ -1438,6 +1438,64 @@
 
 (test #\[ syntax-property (syntax/loc #'a [b c]) 'paren-shape)
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check that inlining expansion of keyword-argument calls
+;; attaches 'alias-of and 'converted-arguments-variant-of
+;; syntax properties:
+
+(parameterize ([current-namespace (make-base-namespace)])
+  (eval '(require (for-syntax racket/base
+                              racket/keyword-transform)))
+  (eval '(module m racket/base (provide f) (define (f #:x [x 2]) x)))
+  (eval '(require 'm))
+  (eval '(define-syntax (extract stx)
+           (syntax-case stx ()
+             [(_ form pattern var alias?)
+              (with-syntax ([e (local-expand #'form 'top-level '())])
+                #'(let-syntax ([m (lambda (stx)
+                                    (syntax-case (quote-syntax e) ()
+                                      [pattern
+                                       #`(quote-syntax (var
+                                                        .
+                                                        #,((if alias?
+                                                               syntax-procedure-alias-property
+                                                               syntax-procedure-converted-arguments-property)
+                                                           #'var)))]))])
+                    (define p (m))
+                    (and (free-identifier=? (car (syntax-e p))
+                                            (cdr (syntax-e (cdr (syntax-e p)))))
+                         (car (syntax-e (cdr (syntax-e p)))))))])))
+  (define f-id (eval '(quote-syntax f)))
+  (test
+   #t
+   free-identifier=?
+   f-id
+   (eval '(extract (f #:x 8)
+                   (lv ([(proc) f2] . _) (if const? (app f3 . _) . _))
+                   f3
+                   #f)))
+  (test
+   #t
+   free-identifier=?
+   f-id
+   (eval '(extract (f #:x 8)
+                   (lv ([(proc) f2] . _) (if const? (app f3 . _) . _))
+                   f2
+                   #t)))
+  (test
+   #t
+   free-identifier=?
+   f-id
+   (eval '(extract (f #:y 9)
+                   (lv ([(proc) f2] . _) . _)
+                   f2
+                   #t)))
+  (test
+   #t
+   free-identifier=?
+   f-id
+   (eval '(extract f f2 f2 #t))))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)