|
|
|
@ -1,5 +1,5 @@
|
|
|
|
|
#lang racket/base
|
|
|
|
|
(require "util.rkt" syntax/id-table)
|
|
|
|
|
(require "util.rkt" syntax/id-table racket/syntax)
|
|
|
|
|
(provide parse)
|
|
|
|
|
|
|
|
|
|
(define (bad-args stx num)
|
|
|
|
@ -32,24 +32,21 @@
|
|
|
|
|
;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.rkt)
|
|
|
|
|
;; checks for errors and generates the plain s-exp form for s
|
|
|
|
|
;; Expands lex-abbrevs and applies lex-trans.
|
|
|
|
|
(define (parse stx disappeared-uses)
|
|
|
|
|
(define (parse stx)
|
|
|
|
|
(let loop ([stx stx]
|
|
|
|
|
[disappeared-uses disappeared-uses]
|
|
|
|
|
;; seen-lex-abbrevs: id-table
|
|
|
|
|
[seen-lex-abbrevs (make-immutable-free-id-table)])
|
|
|
|
|
(let ([recur (λ (s)
|
|
|
|
|
(loop (syntax-rearm s stx)
|
|
|
|
|
disappeared-uses
|
|
|
|
|
seen-lex-abbrevs))]
|
|
|
|
|
[recur/abbrev (λ (s id)
|
|
|
|
|
(loop (syntax-rearm s stx)
|
|
|
|
|
disappeared-uses
|
|
|
|
|
(free-id-table-set seen-lex-abbrevs id id)))])
|
|
|
|
|
(syntax-case (disarm stx) (repetition union intersection complement concatenation
|
|
|
|
|
char-range char-complement)
|
|
|
|
|
[_
|
|
|
|
|
(identifier? stx)
|
|
|
|
|
(let ([expansion (syntax-local-value stx (λ () #f))])
|
|
|
|
|
(let ([expansion (syntax-local-value/record stx (λ (v) #t))])
|
|
|
|
|
(unless (lex-abbrev? expansion)
|
|
|
|
|
(raise-syntax-error 'regular-expression
|
|
|
|
|
"undefined abbreviation"
|
|
|
|
@ -61,7 +58,6 @@
|
|
|
|
|
stx
|
|
|
|
|
#f
|
|
|
|
|
(list (free-id-table-ref seen-lex-abbrevs stx))))
|
|
|
|
|
(set-box! disappeared-uses (cons stx (unbox disappeared-uses)))
|
|
|
|
|
(recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))]
|
|
|
|
|
[_
|
|
|
|
|
(or (char? (syntax-e stx)) (string? (syntax-e stx)))
|
|
|
|
@ -111,8 +107,7 @@
|
|
|
|
|
`(char-complement ,parsed))]
|
|
|
|
|
((OP form ...)
|
|
|
|
|
(identifier? #'OP)
|
|
|
|
|
(let* ([expansion (syntax-local-value #'OP (λ () #f))])
|
|
|
|
|
(set-box! disappeared-uses (cons #'OP (unbox disappeared-uses)))
|
|
|
|
|
(let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))])
|
|
|
|
|
(cond
|
|
|
|
|
[(lex-trans? expansion)
|
|
|
|
|
(recur ((lex-trans-f expansion) (disarm stx)))]
|
|
|
|
@ -164,27 +159,25 @@
|
|
|
|
|
;; and by "now", I mean it's been broken since before we
|
|
|
|
|
;; moved to git.
|
|
|
|
|
(module+ test
|
|
|
|
|
(check-equal? (parse #'#\a null) #\a)
|
|
|
|
|
(check-equal? (parse #'"1" null) "1")
|
|
|
|
|
(check-equal? (parse #'(repetition 1 1 #\1) null)
|
|
|
|
|
(check-equal? (parse #'#\a) #\a)
|
|
|
|
|
(check-equal? (parse #'"1") "1")
|
|
|
|
|
(check-equal? (parse #'(repetition 1 1 #\1))
|
|
|
|
|
'(repetition 1 1 #\1))
|
|
|
|
|
(check-equal? (parse #'(repetition 0 +inf.0 #\1) null) '(repetition 0 +inf.0 #\1))
|
|
|
|
|
(check-equal? (parse #'(union #\1 (union "2") (union)) null)
|
|
|
|
|
(check-equal? (parse #'(repetition 0 +inf.0 #\1)) '(repetition 0 +inf.0 #\1))
|
|
|
|
|
(check-equal? (parse #'(union #\1 (union "2") (union)))
|
|
|
|
|
'(union #\1 (union "2") (union)))
|
|
|
|
|
(check-equal? (parse #'(intersection #\1 (intersection "2") (intersection))
|
|
|
|
|
null)
|
|
|
|
|
(check-equal? (parse #'(intersection #\1 (intersection "2") (intersection)))
|
|
|
|
|
'(intersection #\1 (intersection "2") (intersection)))
|
|
|
|
|
(check-equal? (parse #'(complement (union #\1 #\2))
|
|
|
|
|
null)
|
|
|
|
|
(check-equal? (parse #'(complement (union #\1 #\2)))
|
|
|
|
|
'(complement (union #\1 #\2)))
|
|
|
|
|
(check-equal? (parse #'(concatenation "1" "2" (concatenation)) null)
|
|
|
|
|
(check-equal? (parse #'(concatenation "1" "2" (concatenation)))
|
|
|
|
|
'(concatenation "1" "2" (concatenation)))
|
|
|
|
|
(check-equal? (parse #'(char-range "1" #\1) null) '(char-range #\1 #\1))
|
|
|
|
|
(check-equal? (parse #'(char-range #\1 "1") null) '(char-range #\1 #\1))
|
|
|
|
|
(check-equal? (parse #'(char-range "1" "3") null) '(char-range #\1 #\3))
|
|
|
|
|
(check-equal? (parse #'(char-complement (union "1" "2")) null)
|
|
|
|
|
(check-equal? (parse #'(char-range "1" #\1)) '(char-range #\1 #\1))
|
|
|
|
|
(check-equal? (parse #'(char-range #\1 "1")) '(char-range #\1 #\1))
|
|
|
|
|
(check-equal? (parse #'(char-range "1" "3")) '(char-range #\1 #\3))
|
|
|
|
|
(check-equal? (parse #'(char-complement (union "1" "2")))
|
|
|
|
|
'(char-complement (union "1" "2")))
|
|
|
|
|
(check-equal? (parse #'(char-complement (repetition 1 1 "1")) null)
|
|
|
|
|
(check-equal? (parse #'(char-complement (repetition 1 1 "1")))
|
|
|
|
|
'(char-complement (repetition 1 1 "1")))
|
|
|
|
|
(check-exn #rx"not a character set"
|
|
|
|
|
(λ () (parse #'(char-complement (repetition 6 6 "1")) null))))
|
|
|
|
|
(λ () (parse #'(char-complement (repetition 6 6 "1"))))))
|
|
|
|
|