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