You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
br-parser-tools/collects/parser-tools/private-yacc/parser-builder.ss

96 lines
3.8 KiB
Scheme

(module parser-builder mzscheme
(require "input-file-parser.ss"
"grammar.ss"
"table.ss"
(lib "class.ss")
(lib "contract.ss"))
(require-for-template mzscheme)
(provide/contract
(build-parser ((string? any? any? (listof identifier?) (listof identifier?)
(listof identifier?) (union syntax? false?) syntax?) . ->* .
(any? any? any? any?))))
(define (strip so)
(syntax-local-introduce
(datum->syntax-object
#f
(syntax-object->datum so)
so
so)))
;; fix-check-syntax : (listof identifier?) (listof identifier?) (listof identifier?)
;; (union syntax? false?) syntax?) -> syntax?
(define (fix-check-syntax input-terms start end assocs prods)
(let* ((term-binders (get-term-list input-terms))
(get-term-binder
(let ((t (make-hash-table)))
(for-each
(lambda (term)
(hash-table-put! t (syntax-e term) term))
term-binders)
(lambda (x)
(hash-table-get t (syntax-e x) (lambda () x)))))
(rhs-list
(syntax-case prods ()
(((_ rhs ...) ...)
(syntax->list (syntax (rhs ... ...)))))))
(with-syntax (((tmp ...) term-binders)
((term-group ...)
(map (lambda (tg)
(syntax-property
(datum->syntax-object tg #f)
'disappeared-use
tg))
input-terms))
((end ...)
(map get-term-binder end))
((bind ...)
(syntax-case prods ()
(((bind _ ...) ...) (syntax->list (syntax (bind ...))))))
(((bound ...) ...)
(map
(lambda (rhs)
(syntax-case rhs ()
(((bound ...) (_ pbound) __)
(map get-term-binder
(cons (syntax pbound)
(syntax->list (syntax (bound ...))))))
(((bound ...) _)
(map get-term-binder
(syntax->list (syntax (bound ...)))))))
rhs-list))
((prec ...)
(if assocs
(map get-term-binder
(syntax-case assocs ()
((_ (__ term ...) ...)
(syntax->list (syntax (term ... ...))))))
null)))
#`(when #f
(let ((bind void) ... (tmp void) ...)
(void bound ... ... term-group ... end ... prec ...))))))
(define (build-parser filename src-pos suppress input-terms start end assocs prods)
(let* ((grammar (parse-input input-terms start end assocs prods src-pos))
(table (build-table grammar filename suppress))
(num-non-terms (send grammar get-num-non-terms))
(token-code
`(let ((ht (make-hash-table)))
(begin
,@(map (lambda (term)
`(hash-table-put! ht
',(gram-sym-symbol term)
,(+ num-non-terms (gram-sym-index term))))
(send grammar get-terms))
ht)))
(actions-code
`(vector ,@(map prod-action (send grammar get-prods)))))
(values table
token-code
actions-code
(fix-check-syntax input-terms start end assocs prods))))
)