mbutterick
/
brag
1
0
Fork 0
Code Issues 3 Pull Requests 1 Projects Releases Wiki Activity

obscurity

Browse Source
pull/6/head
Matthew Butterick 7 years ago
parent 93fcabcc51
commit 79cddb19f2
1 changed files with 70 additions and 66 deletions
Show Stats Download Patch File Download Diff File

136
br-parser-tools/br-parser-tools-lib/br-parser-tools/cfg-parser.rkt
Unescape Escape View File

@ -489,6 +489,12 @@
(fail-k max-depth tasks))))]) (fail-k max-depth tasks))))])
(k end max-depth tasks new-got-k new-fail-k)))]))))) (k end max-depth tasks new-got-k new-fail-k)))])))))
;; These temp identifiers can't be `gensym` or `generate-temporary`
;; because they have to be consistent between module loads
;; (IIUC, the parser is multi-threaded, and this approach is not thread-safe)
;; so I see no alternative to the old standby of making them ludicrously unlikely
(define-for-syntax start-id-temp 'start_jihqolbbafscgxvsufnepvmxqipnxgmlpxukmdoqxqzmzgaogaftbkbyqjttwwfimifowdxfyekjiixdmtprfkcvfciraehoeuaz)
(define-for-syntax atok-id-temp 'atok_wrutdjgecmybyfipiwsgjlvsveryodlgassuzcargiuznzgdghrykfqfbwcjgzdhdoeqxcucmtjkuyucskzethozhqkasphdwbht)
(define-syntax (cfg-parser stx) (define-syntax (cfg-parser stx)
(syntax-case stx () (syntax-case stx ()
[(_ clause ...) [(_ clause ...)
@ -652,72 +658,70 @@
pats (caddr old-list)))) pats (caddr old-list))))
nt-ids patss) nt-ids patss)
;; Build a definition for each non-term: ;; Build a definition for each non-term:
(let ([start-id-temp (gensym)] (loop (cdr clauses)
[atok-id-temp (gensym)]) cfg-start
(loop (cdr clauses) (map (lambda (nt pats handles $ctxs)
cfg-start (define info (bound-identifier-mapping-get nts nt))
(map (lambda (nt pats handles $ctxs) (list nt
(define info (bound-identifier-mapping-get nts nt)) #`(let ([key (gensym '#,nt)])
(list nt (lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks)
#`(let ([key (gensym '#,nt)]) (parse-nt/share
(lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks) key #,(car info) '#,(cadr info) stream last-consumed-token depth end
(parse-nt/share max-depth tasks
key #,(car info) '#,(cadr info) stream last-consumed-token depth end success-k fail-k
max-depth tasks (lambda (end max-depth tasks success-k fail-k)
success-k fail-k #,(let loop ([pats pats]
(lambda (end max-depth tasks success-k fail-k) [handles (syntax->list handles)]
#,(let loop ([pats pats] [$ctxs (syntax->list $ctxs)]
[handles (syntax->list handles)] [simple?s (caddr info)])
[$ctxs (syntax->list $ctxs)] (if (null? pats)
[simple?s (caddr info)]) #'(fail-k max-depth tasks)
(if (null? pats) #`(#,(if (or (null? (cdr pats))
#'(fail-k max-depth tasks) (car simple?s))
#`(#,(if (or (null? (cdr pats)) #'parse-or
(car simple?s)) #'parse-parallel-or)
#'parse-or (lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks)
#'parse-parallel-or) #,(build-match nts
(lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks) toks
#,(build-match nts (car pats)
toks (car handles)
(car pats) (car $ctxs)))
(car handles) (lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks)
(car $ctxs))) #,(loop (cdr pats)
(lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks) (cdr handles)
#,(loop (cdr pats) (cdr $ctxs)
(cdr handles) (cdr simple?s)))
(cdr $ctxs) stream last-consumed-token depth end success-k fail-k max-depth tasks)))))))))
(cdr simple?s))) nt-ids
stream last-consumed-token depth end success-k fail-k max-depth tasks))))))))) patss
nt-ids (syntax->list #'(((begin handle0 handle ...) ...) ...))
patss (syntax->list #'((handle0 ...) ...)))
(syntax->list #'(((begin handle0 handle ...) ...) ...)) cfg-error
(syntax->list #'((handle0 ...) ...))) src-pos?
cfg-error (list*
src-pos? (with-syntax ([((tok tok-id . $e) ...)
(list* (token-identifier-mapping-map toks
(with-syntax ([((tok tok-id . $e) ...) (lambda (k v)
(token-identifier-mapping-map toks (list* k
(lambda (k v) (car v)
(list* k (if (cdr v)
(car v) #f
(if (cdr v) '$1))))]
#f [(pos ...)
'$1))))] (if src-pos?
[(pos ...) #'($1-start-pos $1-end-pos)
(if src-pos? #'(#f #f))]
#'($1-start-pos $1-end-pos) ;; rename `start` and `atok` to temp ids
#'(#f #f))] ;; so that "start" and "atok" can be used as literal string tokens in a grammar.
;; rename `start` and `atok` to temp ids ;; not sure why this works, but it passes all tests.
;; so that "start" and "atok" can be used as literal string tokens in a grammar. [%start start-id-temp]
;; not sure why this works, but it passes all tests. [%atok atok-id-temp])
[%start start-id-temp] #`(grammar (%start [() null]
[%atok atok-id-temp]) [(%atok %start) (cons $1 $2)])
#`(grammar (%start [() null] (%atok [(tok) (make-tok 'tok-id 'tok $e pos ...)] ...)))
[(%atok %start) (cons $1 $2)]) (with-syntax ([%start start-id-temp])
(%atok [(tok) (make-tok 'tok-id 'tok $e pos ...)] ...))) #`(start %start))
(with-syntax ([%start start-id-temp]) parser-clauses)))]
#`(start %start))
parser-clauses))))]
[(grammar . _) [(grammar . _)
(raise-syntax-error (raise-syntax-error
#f #f

Write Preview
Loading…
Cancel
Save