commit f7c6d5a21ad7ca01432a5c396eb15b626c7f5846
parent 0410d1eb0732467c16e8dcf8135fc97a7bbd408b
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sat, 4 Feb 2017 09:09:29 +0100
First half of the lifted variables fix.
Diffstat:
5 files changed, 85 insertions(+), 10 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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?])]{
