syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Minor refactoring

This commit is contained in:
Tony Garnock-Jones 2021-06-08 09:30:29 +02:00
parent 5d1e266ea3
commit b22ed84bdb
1 changed files with 34 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
syndicate/pattern.rkt
View File

@ -186,49 +186,49 @@
#`(Pattern-DLit (DLit other))])) #`(Pattern-DLit (DLit other))]))
(define (analyse-pattern-bindings stx) (define (analyse-pattern-bindings stx)
(define disarmed-stx (syntax-disarm stx orig-insp)) (let walk ((stx stx))
(syntax-case disarmed-stx ($ quasiquote unquote quote) (define disarmed-stx (syntax-disarm stx orig-insp))
[(ctor args ...) (syntax-case disarmed-stx ($ quasiquote unquote quote)
(constructor-registered? #'ctor) [(ctor args ...)
((free-id-table-ref preserves-pattern-registry #'ctor) 'bindings disarmed-stx)] (constructor-registered? #'ctor)
((free-id-table-ref preserves-pattern-registry #'ctor) 'bindings disarmed-stx)]
[(expander args ...) [(expander args ...)
(pattern-expander-id? #'expander) (pattern-expander-id? #'expander)
(pattern-expander-transform disarmed-stx (pattern-expander-transform disarmed-stx
(lambda (result) (lambda (result) (walk (syntax-rearm result stx))))]
(analyse-pattern-bindings (syntax-rearm result stx))))]
;; Extremely limited support for quasiquoting and quoting ;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (analyse-pattern-bindings #'p)] [(quasiquote (unquote p)) (walk #'p)]
[(quasiquote (p ...)) (analyse-pattern-bindings #'(list (quasiquote p) ...))] [(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
[(quasiquote _p) '()] [(quasiquote _p) '()]
[(quote _p) '()] [(quote _p) '()]
[(ctor piece ...) [(ctor piece ...)
(struct-info? (id-value #'ctor)) (struct-info? (id-value #'ctor))
(append-map analyse-pattern-bindings (syntax->list #'(piece ...)))] (append-map walk (syntax->list #'(piece ...)))]
[(list-stx piece ...) [(list-stx piece ...)
(list-id? #'list-stx) (list-id? #'list-stx)
(append-map analyse-pattern-bindings (syntax->list #'(piece ...)))] (append-map walk (syntax->list #'(piece ...)))]
[(hash-stx piece ...) [(hash-stx piece ...)
(hash-or-hasheqv-id? #'hash-stx) (hash-or-hasheqv-id? #'hash-stx)
(append-map-pairs (lambda (_k v) (analyse-pattern-bindings v)) (syntax->list #'(piece ...)))] (append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
[id [id
(dollar-id? #'id) (dollar-id? #'id)
(list (undollar #'id))] (list (undollar #'id))]
[($ id p) [($ id p)
(cons #'id (analyse-pattern-bindings #'p))] (cons #'id (walk #'p))]
[id [id
(discard-id? #'id) (discard-id? #'id)
'()] '()]
[other [other
'()])) '()])))
(define (analyse-template stx) (define (analyse-template stx)
(syntax-case stx ($ quasiquote unquote quote) (syntax-case stx ($ quasiquote unquote quote)