156 lines
6.8 KiB
Racket
156 lines
6.8 KiB
Racket
#lang racket/base
|
|
(require syntax/parse
|
|
racket/syntax
|
|
unstable/syntax
|
|
"re-help.rkt"
|
|
(for-template racket/base
|
|
racket/match
|
|
"machine.rkt"
|
|
(except-in "nfa-star.rkt" epsilon)
|
|
(prefix-in nfa: "nfa-star.rkt")))
|
|
|
|
(define-literal-set re-ops (complement seq union star epsilon nullset dseq rec unquote))
|
|
|
|
(define-syntax-class sre
|
|
#:literal-sets (re-ops)
|
|
#:description "Fully Expanded Regular Expression"
|
|
; nfa is used for res without complement or dseq
|
|
; machine is used for others
|
|
; all-machines is machines all the way down, no nfas
|
|
; best is the best thing to embed in a machine
|
|
#:attributes (nfa machine all-machines best)
|
|
(pattern ((~and op unquote) e:expr)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa #f
|
|
#:attr machine
|
|
; XXX contract to be a machine?
|
|
#`e
|
|
#:attr all-machines (attribute machine)
|
|
#:attr best (attribute machine))
|
|
|
|
; XXX This may not need to be built in because of unquote
|
|
(pattern ((~and op rec) v:id lhs:sre)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa #f
|
|
#:attr machine
|
|
#`(letrec ([inner
|
|
(let-syntax ([v
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
; Redirect mutation of x to y
|
|
[(set! _ _)
|
|
(raise-syntax-error 'rec "Cannot mutate a rec binding" stx)]
|
|
; Normal use of x really gets x
|
|
[id (identifier? #'id) #'(machine-delay (λ () inner))])))])
|
|
#,(attribute lhs.best))])
|
|
inner)
|
|
#:attr all-machines (attribute machine)
|
|
#:attr best (attribute machine))
|
|
|
|
(pattern ((~and op complement) lhs:sre)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa #f
|
|
#:attr machine
|
|
#`(machine-complement #,(attribute lhs.best))
|
|
#:attr all-machines
|
|
#`(machine-complement #,(attribute lhs.all-machines))
|
|
#:attr best (attribute machine))
|
|
|
|
(pattern ((~and op star) lhs:sre)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa
|
|
(and (attribute lhs.nfa)
|
|
(with-syntax*
|
|
([start_star (generate-temporary 'start_star)]
|
|
[(_ (starts_1 ...) ([accepting-state_1 (accepting-rule_1 ...)] ...) (non-accepting_1 ...))
|
|
(attribute lhs.nfa)])
|
|
#'(nfa* (start_star)
|
|
([start_star ([nfa:epsilon (starts_1 ...)])])
|
|
([accepting-state_1 ([nfa:epsilon (start_star)] accepting-rule_1 ...)] ...
|
|
non-accepting_1 ...))))
|
|
#:attr machine
|
|
#`(machine-star #,(attribute lhs.best))
|
|
#:attr all-machines
|
|
#`(machine-star #,(attribute lhs.all-machines))
|
|
#:attr best (or (attribute nfa) (attribute machine)))
|
|
|
|
(pattern ((~and op seq) lhs:sre rhs:sre)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa
|
|
(and (attribute lhs.nfa)
|
|
(attribute rhs.nfa)
|
|
(with-syntax*
|
|
([(_ (starts_1 ...) ([accepting-state_1 (accepting-rule_1 ...)] ...) (non-accepting_1 ...))
|
|
(attribute lhs.nfa)]
|
|
[(_ (starts_2 ...) (accepting_2 ...) (non-accepting_2 ...))
|
|
(attribute rhs.nfa)]
|
|
[([accepting-state_2 . _] ...) #'(accepting_2 ...)])
|
|
#'(nfa* (starts_1 ...)
|
|
(accepting_2 ...)
|
|
([accepting-state_1 ([nfa:epsilon (starts_2 ...)] accepting-rule_1 ...)] ...
|
|
non-accepting_1 ...
|
|
non-accepting_2 ...))))
|
|
#:attr machine
|
|
#`(machine-seq #,(attribute lhs.best) #,(attribute rhs.best))
|
|
#:attr all-machines
|
|
#`(machine-seq #,(attribute lhs.all-machines) #,(attribute rhs.all-machines))
|
|
#:attr best (or (attribute nfa) (attribute machine)))
|
|
|
|
(pattern ((~and op union) lhs:sre rhs:sre)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa
|
|
(and (attribute lhs.nfa)
|
|
(attribute rhs.nfa)
|
|
(with-syntax*
|
|
([(_ (starts_1 ...) (accepting_1 ...) (non-accepting_1 ...)) (attribute lhs.nfa)]
|
|
[(_ (starts_2 ...) (accepting_2 ...) (non-accepting_2 ...)) (attribute rhs.nfa)])
|
|
#'(nfa* (starts_1 ... starts_2 ...)
|
|
(accepting_1 ... accepting_2 ...)
|
|
(non-accepting_1 ... non-accepting_2 ...))))
|
|
#:attr machine
|
|
#`(machine-union #,(attribute lhs.best) #,(attribute rhs.best))
|
|
#:attr all-machines
|
|
#`(machine-union #,(attribute lhs.all-machines) #,(attribute rhs.all-machines))
|
|
#:attr best (or (attribute nfa) (attribute machine)))
|
|
|
|
(pattern (~and op epsilon)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa
|
|
(with-syntax ([start (generate-temporary 'start)])
|
|
#'(nfa* (start) ([start ()]) ()))
|
|
#:attr machine
|
|
#'machine-epsilon
|
|
#:attr all-machines (attribute machine)
|
|
#:attr best (attribute machine))
|
|
|
|
(pattern (~and op nullset)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa
|
|
(with-syntax ([end (generate-temporary 'end)])
|
|
#'(nfa* (end) () ([end ()])))
|
|
#:attr machine
|
|
#'machine-null
|
|
#:attr all-machines (attribute machine)
|
|
#:attr best (attribute machine))
|
|
|
|
(pattern ((~and op dseq) pat:expr rhs:sre)
|
|
#:do [(record-disappeared-uses (list #'op))]
|
|
#:attr nfa #f
|
|
#:attr machine
|
|
#`(machine '(dseq pat) (match-lambda [pat #,(attribute rhs.best)] [_ machine-null]))
|
|
#:attr all-machines (attribute machine)
|
|
#:attr best (attribute machine))
|
|
|
|
(pattern pat:expr
|
|
#:attr nfa
|
|
(with-syntax ([start (generate-temporary #'pat)]
|
|
[end (generate-temporary 'end)])
|
|
#'(nfa* (start) ([end ()]) ([start ([pat (end)])])))
|
|
#:attr machine
|
|
#'(machine 'pat (match-lambda [pat machine-epsilon] [_ machine-null]))
|
|
#:attr all-machines (attribute machine)
|
|
#:attr best (attribute machine)))
|
|
|
|
(provide sre)
|