From f7c6d5a21ad7ca01432a5c396eb15b626c7f5846 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sat, 4 Feb 2017 09:09:29 +0100 Subject: [PATCH] First half of the lifted variables fix. --- private/ddd.rkt | 62 +++++++++++++++++++--- private/lifted-variables-communication.rkt | 26 +++++++++ private/subscripts.rkt | 1 - private/template-subscripts.rkt | 1 + scribblings/subtemplate.scrbl | 4 +- 5 files changed, 84 insertions(+), 10 deletions(-) create mode 100644 private/lifted-variables-communication.rkt diff --git a/private/ddd.rkt b/private/ddd.rkt index d97e474..abd8217 100644 --- a/private/ddd.rkt +++ b/private/ddd.rkt @@ -7,6 +7,8 @@ phc-toolkit/untyped subtemplate/private/copy-attribute (prefix-in - syntax/parse/private/residual) + racket/stxparam + "lifted-variables-communication.rkt" (for-syntax racket/contract racket/syntax phc-toolkit/untyped @@ -20,6 +22,7 @@ (define-for-syntax x-pvar-scope (make-syntax-introducer)) (define-for-syntax x-pvar-present-marker (make-syntax-introducer)) +(define-for-syntax x-lifted-pvar-marker (make-syntax-introducer)) (begin-for-syntax (define/contract (attribute-real-valvar attr) @@ -114,6 +117,7 @@ bound-identifier=?)) (define-for-syntax (extract-present-variables expanded-form stx) + ;; present-variables vector (define present-variables** (find-present-variables-vector expanded-form)) (define present-variables* (and (vector? present-variables**) @@ -126,7 +130,23 @@ " pattern variables present in the body.") stx)) (define present-variables (map syntax-e present-variables*)) - present-variables) + + ;; lifted variables + (define lifted-variables + (map (λ (id) + (define prop (syntax-property id 'lifted-pvar)) + (unless ((cons/c symbol? syntax?) prop) + (raise-syntax-error 'ddd + (string-append + "internal error: 'lifted-pvar property was" + " missing or not a (cons/c symbol? syntax?).") + stx)) + prop) + (filter (λ (id) (all-scopes-in? x-lifted-pvar-marker id)) + (extract-ids expanded-form)))) + + + (values present-variables lifted-variables)) ;(struct splicing-list (l) #:transparent) (require "cross-phase-splicing-list.rkt") @@ -151,9 +171,11 @@ 'expression '())) - (define present-variables + (define-values (present-variables lifted-variables) (extract-present-variables #'expanded-condition stx)) + (displayln lifted-variables) + (define/with-syntax (test-present-attribute …) (for/list ([present? (in-list present-variables)] [pv (in-syntax #'(pvar …))] @@ -201,20 +223,46 @@ (datum->syntax stx `(,#'self ,#'a ,else) stx stx))])) (parse stx)) +;;; The body is wrapped in a lambda, with one pvarᵢ for each pvar within scope. +;;; This is used to shadow the pvar with one equal to pvarᵢ, which iterates over +;;; the original pvar. Inside that function, the body is wrapped with +;;; detect-present-pvars, which fully expands the body, leaving a quoted vector +;;; of booleans indicating which pvars are actually used within the body. The +;;; vector is identified by the x-pvar-present-marker scope (created with +;;; make-syntax-introducer), and the extract-present-variables utility finds +;;; that vector in the fully-expanded syntax object. +;;; Auto-generated subscripted pattern variables would normally be derived from +;;; the shadowed pvar. However, this means that within two different ddd forms, +;;; the auto-generated subscripted pvars would be derived from different pvars +;;; (two shadowed copies of the original). This means that the generated pvars +;;; would contain different values. To solve this problem, ddd collaborates with +;;; template-subscripts.rkt. When a subscripted pvar is encountered within a ddd +;;; form, template-subscripts.rkt does not auto-generate its contents. +;;; Instead, it extracts the value of the variable from an additionnal +;;; lifted-variables argument (to the function wrapping the body), and notes down, +;;; marking it with the special scope x-lifted-pvar-marker, so that +;;; extract-present-variables can find it. +;;; In effect, this is semantically equivalent to lifting the problematic +;;; pvar outside of the body. (define-syntax/case (ddd body) () (define/with-syntax (pvar …) (current-pvars-shadowers)) (define-temp-ids "~aᵢ" (pvar …)) (define/with-syntax f - #`(#%plain-lambda (pvarᵢ …) + #`(#%plain-lambda (pvarᵢ … lifted-variables-hash) (shadow pvar pvarᵢ) … - (detect-present-pvars (pvar …) - body))) + (syntax-parameterize ([lift-late-pvars-param + #'lifted-variables-hash]) + (detect-present-pvars (pvar …) + body)))) ;; extract all the variable ids present in f (define/with-syntax expanded-f (local-expand #'f 'expression '())) - (define present-variables (extract-present-variables #'expanded-f stx)) + (define-values (present-variables lifted-variables) + (extract-present-variables #'expanded-f stx)) + + (displayln lifted-variables) (unless (ormap identity present-variables) (raise-syntax-error 'ddd @@ -250,7 +298,7 @@ present?+pvars))) #'(map#f* (λ (iterated-pvarᵢ …) - (expanded-f filling-pvar …)) + (expanded-f filling-pvar … #false)) ;; TODO: the lifted pvars here ………………………………………… (list (quote-syntax iterated-pvar) …) (list (attribute* iterated-pvar) diff --git a/private/lifted-variables-communication.rkt b/private/lifted-variables-communication.rkt new file mode 100644 index 0000000..73f1c20 --- /dev/null +++ b/private/lifted-variables-communication.rkt @@ -0,0 +1,26 @@ +#lang racket/base + +(provide lift-late-pvars-param + (for-syntax lift-late-pvars-target)) + +(require racket/stxparam + (for-syntax racket/base + racket/syntax + racket/contract)) + +(define-syntax-parameter lift-late-pvars-param #f) + +(define-for-syntax (lift-late-pvars-target) + (syntax-parameter-value #'must-lift-late-pvars?-param)) + +;; Returns two values, the syntax to insert, and a symbol to use at run-time +;; to access the value of that lifted pvar. +(begin-for-syntax + (define/contract (lifted-pvar name expr-stx) + (-> symbol? syntax? (values symbol? syntax?)) + (define lifted-symbol (gensym (format "lifted-~a" name))) + (define lifted-hint-id (generate-temporary lifted-symbol)) + (values (syntax-property lifted-hint-id + 'late-pvar + (cons lifted-symbol expr-stx)) + lifted-symbol))) \ No newline at end of file diff --git a/private/subscripts.rkt b/private/subscripts.rkt index 975f5db..f64ac65 100644 --- a/private/subscripts.rkt +++ b/private/subscripts.rkt @@ -116,7 +116,6 @@ (syntax/c (listof identifier?)) ; binders (syntax/c (listof identifier?)) ; unique-at-runtime ids exact-nonnegative-integer?))) ; ellipsis-depth - (let/cc return ;; EARLY RETURN (already a pattern variable) (when (syntax-pattern-variable? diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt index 1b5adf0..c2979fa 100644 --- a/private/template-subscripts.rkt +++ b/private/template-subscripts.rkt @@ -17,6 +17,7 @@ syntax/id-table (subtract-in racket/syntax stxparse-info/case) "copy-attribute.rkt" + "lifted-variables-communication.rkt" (for-syntax (subtract-in racket/base srfi/13) "patch-arrows.rkt" "subscripts.rkt" diff --git a/scribblings/subtemplate.scrbl b/scribblings/subtemplate.scrbl index 1d67a1b..a852d68 100644 --- a/scribblings/subtemplate.scrbl +++ b/scribblings/subtemplate.scrbl @@ -183,8 +183,8 @@ to their equivalents from this library, and without @orig:template/loc] and corresponding @racket[xᵢ …] which is bound as a syntax pattern variable, in the same way as @racket[subtemplate].} -@defform*[{(template template) - (template template #:properties (prop ...))} +@defform*[{(template _template) + (template _template #:properties (prop ...))} #:contracts ([prop identifier?])]{