www

commit 406698e113021b12298df401082e7682b69abdfb
parent 5ba9ab5130c7f4de082ce2a8361cf2586ecc1e2c
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Sun, 29 Jan 2017 23:48:40 +0100

Restored derived-valvar

Diffstat:
M
derived-valvar.rkt
 | 
37
++++++++++---------------------------
M
main.rkt
 | 
6
++----

2 files changed, 12 insertions(+), 31 deletions(-)
diff --git a/derived-valvar.rkt b/derived-valvar.rkt
@@ -1,24 +1,20 @@
 #lang racket/base
 
-(provide valvar+props
-         valvar+props-valvar
-         valvar+props-properties
-         pvar->valvar+props
-         pvar-property)
+(provide (struct-out derived-valvar)
+         id-is-derived-valvar?)
 
 (require racket/function
-         racket/contract
          racket/private/sc
          (for-template (prefix-in - stxparse-info/parse/private/residual)))
 
 ;; Act like a syntax transformer, but which is recognizable via the
 ;; derived-pattern-variable? predicate.
-(struct valvar+props (valvar properties)
+(struct derived-valvar (valvar)
   #:property prop:procedure
   (λ (self stx)
-    #`(#%expression #,(valvar+props-valvar self))))
+    #`(#%expression #,(derived-valvar-valvar self))))
 
-(define (pvar->valvar+props id)
+(define (id-is-derived-valvar? id)
   (define mapping (syntax-local-value id (thunk #f)))
   (and mapping ;; … defined as syntax
        (syntax-pattern-variable? mapping) ; and is a syntax pattern variable
@@ -28,21 +24,8 @@
          ;; either a mapping → attribute → derived,
          ;; or directly mapping → derived
          (or (and (-attribute-mapping? mapping-slv) ;; is an attribute
-                  (let ([attribute-slv (syntax-local-value
-                                        (-attribute-mapping-var mapping-slv)
-                                        (thunk #f))])
-                    ;; and the pvar's valvar is a derived
-                    (and (valvar+props? attribute-slv)
-                         attribute-slv))
+                  (derived-valvar? ;; and the pvar's valvar is a derived
+                   (syntax-local-value (-attribute-mapping-var mapping-slv)
+                                       (thunk #f))))
              ;; or the pvar's valvar is derived
-             (and (valvar+props? mapping-slv)
-                  mapping-slv))))))
-
-(define/contract (pvar-property id property)
-  (-> identifier? symbol? any/c)
-  (let ([valvar+props (valvar+props-properties id)])
-    (and valvar+props
-         (let ([properties (valvar+props-properties valvar+props)])
-         (hash? properties)
-         (immutable? properties)
-         (hash-ref properties property #f)))))
-\ No newline at end of file
+             (derived-valvar? mapping-slv)))))
+\ No newline at end of file
diff --git a/main.rkt b/main.rkt
@@ -94,9 +94,7 @@
       
       (define/with-syntax ([binder . unique-at-runtime-id] …)
         (filter (compose (conjoin identifier?
-                                  (λ (pv)
-                                    (not
-                                     (pvar-property pv 'subtemplate-derived)))
+                                  (negate id-is-derived-valvar?)
                                   (λ~> (syntax-local-value _ (thunk #f))
                                        syntax-pattern-variable?)
                                   ;; force call syntax-local-value to prevent
@@ -118,7 +116,7 @@
       #;(define/with-syntax ([binder . unique-at-runtime] …)
           (for/list ([binder (current-pvars+unique)]
                       #:when (identifier? (car binder))
-                      #:unless (pvar-property (car binder) 'subtemplate-derived)
+                      #:unless (id-is-derived-valvar? (car binder))
                       #:when (syntax-pattern-variable?
                               (syntax-local-value (car binder) (thunk #f)))
                       ;; force call syntax-local-value to prevent ambiguous