commit eedc88f8e20f6f0c7728cf19a130712c02ad76e2
parent c887cae4fece171b366a1360cd9c102a42163c7c
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sat, 28 Jan 2017 04:55:10 +0100
Closes FB case 193
subtemplate: check that if the hash-table access worked, any new pvars are compatible with the old ones on which the cache is based (in the sense of "no new non-#f positions").
Also check that all derived variables from the same xᵢ have the same shape (i.e. don't filter out derived variables for this check).
Diffstat:
2 files changed, 146 insertions(+), 40 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -189,20 +189,47 @@
(build-compound-type-name 'attribute-val/c depth bottom-predicate)
(λ (l)
(if (= depth 0)
- (or (eq? l #f) (bottom-predicate l))
- (or (eq? l #f)
+ (or (false? l) (bottom-predicate l))
+ (or (false? l)
(and (list? l)
(andmap (attribute-val/c (sub1 depth)) l)))))))
-;; ellipsis-count/c works with attributes too, including missing (optional)
-;; elements in the lists, at any level.
-(define/contract (ellipsis-count/c depth [bottom-predicate any/c])
- (->* {exact-nonnegative-integer?} {flat-contract?} flat-contract?)
+;; Checks that all the given attribute values have the same structure.
+;;
+;; ellipsis-count/c works with the value of pattern variables and of attributes
+;; too, including those missing (optional) elements in the lists, at any level.
+;;
+;; The lists must have the same lengths across all attribute values, including
+;; the missing #f elements.
+;;
+;; If same-shape is #true, a #f in one attribute value implies #f in all other
+;; attribute values at the same position. The same-shape check is not
+;; performed on the bottommost #f values (as they do not influence the shape of
+;; the tree).
+(define/contract (ellipsis-count/c depth
+ [bottom-predicate any/c]
+ #:same-shape [same-shape #f])
+ (->* {exact-nonnegative-integer?}
+ {flat-contract?
+ #:same-shape boolean?}
+ flat-contract?)
+ ;; Must be lazy, otherwise ellipsis-count/c would immediately call itself
+ (define (recur/c sublists)
+ ((ellipsis-count/c (sub1 depth) bottom-predicate #:same-shape same-shape)
+ sublists))
(flat-named-contract
- (build-compound-type-name 'ellipsis-count/c depth bottom-predicate)
+ (apply build-compound-type-name
+ (list* 'ellipsis-count/c depth bottom-predicate
+ (if same-shape
+ (list '#:same-shape same-shape)
+ (list))))
(λ (l*)
(true?
(and (list? l*)
+ (if (and same-shape (> depth 0))
+ (or (andmap false? l*) ;; all #f
+ (andmap identity l*)) ;; all non-#f
+ #t)
(let ([l* (filter identity l*)])
(if (= depth 0)
(andmap bottom-predicate l*)
@@ -211,9 +238,7 @@
(or (empty? l*)
(apply andmap
(λ sublists
- ((ellipsis-count/c (sub1 depth)
- bottom-predicate)
- sublists))
+ (recur/c sublists))
l*)))))))))))
(define/contract (map-merge-stx-depth f l* depth)
@@ -323,6 +348,8 @@
any/c)
(define val (or (for/or ([k (in-list keys)]) (hash-ref h k #f))
to-set))
+ ;; Set the existing value (or new to-set if none) on all keys which
+ ;; are not present in the hash table.
(for ([k (in-list keys)]) (hash-ref! h k val))
val)
@@ -412,6 +439,8 @@
(define/with-syntax temp-derived (generate-temporary #'bound))
(define/with-syntax temp-valvar (generate-temporary #'bound))
(define/with-syntax temp-cached (generate-temporary #'bound))
+ (define/with-syntax temp-generated (generate-temporary #'bound))
+ (define/with-syntax temp-id-table (generate-temporary #'bound))
;; works only for syntax patterns, luckily that's all we need since we
;; produce a tree of (possibly missing) identifiers.
(define/with-syntax copy-attribute-pattern
@@ -434,40 +463,85 @@
;; zᵢ …))])
;; the test above is not exactly right (zᵢ will still have the correct
;; binding), but it gives the general idea.
- #`(begin ;(define-temp-ids #:concise tmp-str binder-ddd) ;;;;;;;;;;;;;;;;;;;TODO: should fuse all the binder-ddd, so that if any one is not #f for a sublist, that sublist is generated.
+ #`(begin
+ (define-values (temp-generated)
+ (generate-nested-ids 'ellipsis-depth
+ (quote-syntax bound)
+ (quote-syntax binder₀)
+ (λ (v) (format tmp-str v))
+ (list (attribute* binder₀)
+ (attribute* binderᵢ)
+ …)
+ (list (quote-syntax binder₀)
+ (quote-syntax binderᵢ)
+ …)
+ whole-form-id))
+ (define-values (temp-id-table)
+ (multi-hash-ref! derived-valvar-cache
+ (list unique-at-runtime-idᵢ
+ …)
+ (make-free-id-table)))
+ (define-values (temp-cached)
+ (free-id-table-ref! temp-id-table
+ (quote-syntax bound)
+ temp-generated))
;; TODO: we should check that if the hash-table access worked,
;; any new pvars are compatible with the old ones on which the cache is
;; based (in the sense of "no new non-#f positions")
- (define temp-cached
- (free-id-table-ref! (multi-hash-ref! derived-valvar-cache
- (list unique-at-runtime-idᵢ
- …)
- (make-free-id-table))
- (quote-syntax bound)
- (λ ()
- (generate-nested-ids 'ellipsis-depth
- (quote-syntax bound)
- (quote-syntax binder₀)
- (λ (v) (format tmp-str v))
- (list (attribute* binder₀)
- (attribute* binderᵢ)
- …)
- (list (quote-syntax binder₀)
- (quote-syntax binderᵢ)
- …)
- whole-form-id))))
- #;(define-syntax temp-derived
- (derived-valvar (quote-syntax temp-cached)))
- #;(define-raw-attribute bound
- temp-valvar
- temp-cached ;temp-derived
- ellipsis-depth
- #t)
- ;(define temp-cached (attribute* binder₀))
+
+ ;; Check that all derived pvars for this subscript from all binders
+ ;; have the same shape, i.e. we wouldn't want some elements to be missing
+ ;; (as in ~optional) at some position from one derived pvar, but not from
+ ;; others. This check implies that the original binder used did not
+ ;; introduce new elements compared to the binders used for other derived
+ ;; pvars, e.g:
+ ;; (syntax-parse #'([1 2 3] #f)
+ ;; [({~and {~or (xᵢ ...) #f}} ...)
+ ;; (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _)
+ ;; (syntax-case #'([a b c] [d e]) ()
+ ;; ;; introduces elements [d e] which were unknown when yᵢ was
+ ;; ;; generated:
+ ;; [((wᵢ ...) ...)
+ ;; ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is
+ ;; ;; inconsistent with the shape of yᵢ.
+ ;; (subtemplate ({?? (zᵢ ...) _} ...))])])
+ ;; The check must also compare temp-generated, even if it was not
+ ;; assigned to #'bound, so that it also cathes the error if we replace
+ ;; zᵢ with yᵢ in the example above.
+ (unless ((ellipsis-count/c ellipsis-depth #:same-shape #t)
+ (cons temp-generated
+ (free-id-table-map temp-id-table (λ (k v) v))))
+ ;; TODO: For now this will just blow up, a better error message would
+ ;; be nice. Especially saying which one failed.
+ (raise-syntax-error
+ 'sublist
+ (format (string-append
+ "some derived variables do not have the same ellipsis"
+ " shape\n"
+ " depth: ~a\n"
+ " attributes...:\n"
+ " ~a\n"
+ " attribute ~a if it were generated here...:\n"
+ " ~a")
+ 'ellipsis-depth
+ (string-join (free-id-table-map
+ temp-id-table
+ (λ (k v)
+ (format "~a => ~a"
+ (syntax-e k)
+ (syntax->datum
+ (datum->syntax #f v)))))
+ "\n ")
+ 'bound
+ (syntax->datum
+ (datum->syntax #f temp-generated)))
+ (quote-syntax whole-form-id)
+ (quote-syntax bound)
+ (free-id-table-map temp-id-table (λ (k v) k))))
+
;; manually creating the attribute with (make-attribute-mapping …)
;; works, but the attribute behaves in a bogus way when put inside
;; an (?@ yᵢ ...). I must be missing some step in the construction
;; of the attribute
- ;; TODO: I used make-attribute-mapping somewhere else, find it and change it !!!!!
(define/syntax-parse copy-attribute-pattern temp-cached)
(define-pvars bound))))
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
@@ -1084,4 +1084,36 @@
h/y ,(? symbol?
(app symbol->string (regexp #rx"xᵢ[0-9]+/y")))
a/y b/y
- l/y m/y n/y o/y))))
-\ No newline at end of file
+ l/y m/y n/y o/y))))
+
+;; Incompatible shapes of different derived attributes:
+(check-exn
+ #rx"some derived variables do not have the same ellipsis shape"
+ (λ ()
+ (convert-compile-time-error
+ (syntax-parse #'([1 2 3] #f)
+ [({~and {~or (xᵢ ...) #f}} ...)
+ (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _)
+ (syntax-case #'([a b c] [d e]) ()
+ ;; introduces elements [d e] which were unknown when yᵢ was
+ ;; generated:
+ [((wᵢ ...) ...)
+ ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is
+ ;; inconsistent with the shape of yᵢ.
+ (subtemplate ({?? (zᵢ ...) _} ...))])]))))
+
+;; Incompatible shapes of the same attribute if it were generated at two
+;; different points.
+(check-exn
+ #rx"some derived variables do not have the same ellipsis shape"
+ (λ ()
+ (syntax-parse #'([1 2 3] #f)
+ [({~and {~or (xᵢ ...) #f}} ...)
+ (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _)
+ (syntax-case #'([a b c] [d e]) ()
+ ;; introduces elements [d e] which were unknown when yᵢ was
+ ;; generated:
+ [((wᵢ ...) ...)
+ ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is
+ ;; inconsistent with the shape of yᵢ.
+ (subtemplate ({?? (yᵢ ...) _} ...))])])))
+\ No newline at end of file
