commit e628554a4821b24b44eea0089f9c8c005717792b
parent 23eba12634c88c0e120ffce2611f9ae0dbe66bcc
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 8 Sep 2016 14:40:36 +0200
Compatibility with v6.5
Diffstat:
| M | private/no-order.rkt | | | 113 | +++++++++++++++++++++++++++++++++++++++---------------------------------------- |
1 file changed, 56 insertions(+), 57 deletions(-)
diff --git a/private/no-order.rkt b/private/no-order.rkt
@@ -66,7 +66,7 @@
(define-for-syntax (fix-disappeared-uses)
;; Fix for https://github.com/racket/racket/issues/1452
(let ([dis (current-recorded-disappeared-uses)])
- #`{~do #,(with-disappeared-uses
+ #`{~do #,(with-disappeared-uses*
(record-disappeared-uses dis)
#'(void))}))
@@ -78,62 +78,61 @@
(λ (stx)
(syntax-case stx ()
[(self pat ...)
- (with-disappeared-uses
- (let ()
- (define counter 0)
- (define (increment-counter)
- (begin0 counter
- (set! counter (add1 counter))))
- ;; post-acc gathers some a-patterns which will be added after the
- ;; (~seq (~or ) ...)
- (define post-acc '())
- (define (add-to-post! v) (set! post-acc (cons v post-acc)))
- ;; post-groups-acc gathers some attributes that have to be grouped
- (define post-groups-acc '())
- (define (add-to-post-groups! . v)
- (set! post-groups-acc (cons v post-groups-acc)))
- ;; expand EH alternatives:
- (parameterize ([eh-post-accumulate add-to-post!]
- [eh-post-group add-to-post-groups!]
- [clause-counter increment-counter])
- (define alts
- (expand-all-eh-mixin-expanders #'(~or pat ...)))
- (define post-group-bindings
- (for/list ([group (group-by car
- post-groups-acc
- free-identifier=?)])
- ;; each item in `group` is a four-element list:
- ;; (list result-id aggregate-function attribute)
- (define/with-syntax name (first (car group))
- #;(syntax-local-introduce
- (datum->syntax #'here
- (first (car group)))))
- (define/with-syntax f (second (car group)))
- #`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
- group))]))
- (define/with-syntax whole-clause (get-new-clause!))
- (define/with-syntax parse-seq-order-sym-id
- (datum->syntax (parse-seq-order-sym-introducer
- (syntax-local-introduce #'here))
- 'parse-seq-order-sym))
- #`(~delimit-cut
- (~and #,(fix-disappeared-uses)
- {~seq whole-clause (… …)}
- {~do (define parse-seq-order-sym-id
- (gensym 'parse-seq-order))}
- {~parse ({~seq #,alts (… …)})
- #`#,(for/list
- ([xi (in-syntax #'(whole-clause (… …)))]
- [i (in-naturals)])
- ;; Add a syntax property before parsing,
- ;; to track the position of matched elements
- ;; using ~order-point
- (syntax-property xi
- parse-seq-order-sym-id
- i))}
- ~!
- (~bind #,@post-group-bindings)
- #,@post-acc)))))]))))
+ (with-disappeared-uses*
+ (define counter 0)
+ (define (increment-counter)
+ (begin0 counter
+ (set! counter (add1 counter))))
+ ;; post-acc gathers some a-patterns which will be added after the
+ ;; (~seq (~or ) ...)
+ (define post-acc '())
+ (define (add-to-post! v) (set! post-acc (cons v post-acc)))
+ ;; post-groups-acc gathers some attributes that have to be grouped
+ (define post-groups-acc '())
+ (define (add-to-post-groups! . v)
+ (set! post-groups-acc (cons v post-groups-acc)))
+ ;; expand EH alternatives:
+ (parameterize ([eh-post-accumulate add-to-post!]
+ [eh-post-group add-to-post-groups!]
+ [clause-counter increment-counter])
+ (define alts
+ (expand-all-eh-mixin-expanders #'(~or pat ...)))
+ (define post-group-bindings
+ (for/list ([group (group-by car
+ post-groups-acc
+ free-identifier=?)])
+ ;; each item in `group` is a four-element list:
+ ;; (list result-id aggregate-function attribute)
+ (define/with-syntax name (first (car group))
+ #;(syntax-local-introduce
+ (datum->syntax #'here
+ (first (car group)))))
+ (define/with-syntax f (second (car group)))
+ #`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
+ group))]))
+ (define/with-syntax whole-clause (get-new-clause!))
+ (define/with-syntax parse-seq-order-sym-id
+ (datum->syntax (parse-seq-order-sym-introducer
+ (syntax-local-introduce #'here))
+ 'parse-seq-order-sym))
+ #`(~delimit-cut
+ (~and #,(fix-disappeared-uses)
+ {~seq whole-clause (… …)}
+ {~do (define parse-seq-order-sym-id
+ (gensym 'parse-seq-order))}
+ {~parse ({~seq #,alts (… …)})
+ #`#,(for/list
+ ([xi (in-syntax #'(whole-clause (… …)))]
+ [i (in-naturals)])
+ ;; Add a syntax property before parsing,
+ ;; to track the position of matched elements
+ ;; using ~order-point
+ (syntax-property xi
+ parse-seq-order-sym-id
+ i))}
+ ~!
+ (~bind #,@post-group-bindings)
+ #,@post-acc))))]))))
(define-syntax ~no-order
(pattern-expander
