diff --git a/collects/racket/keyword-transform.rkt b/collects/racket/keyword-transform.rkt new file mode 100644 index 0000000000..2ceaea04ea --- /dev/null +++ b/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) + diff --git a/collects/racket/private/kw.rkt b/collects/racket/private/kw.rkt index be37b92f41..5f8388b49d 100644 --- a/collects/racket/private/kw.rkt +++ b/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)))] - [_ wrap-id])) + (datum->syntax stx (cons wrap-id/prop #'(arg ...)) stx stx)))] + [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))) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 5dc1d3d6c7..6cdbdfeaab 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/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] diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 35be58c5f1..2ba5aa634c 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/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 ...+] ...) diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index 620697f1fb..823bf2b5ac 100644 --- a/collects/tests/racket/syntax.rktl +++ b/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)