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.
75 lines
2.9 KiB
Scheme
75 lines
2.9 KiB
Scheme
#cs
|
|
(module parser-builder mzscheme
|
|
|
|
(require "input-file-parser.ss"
|
|
"parser-actions.ss"
|
|
"grammar.ss"
|
|
"table.ss"
|
|
(lib "class.ss"))
|
|
|
|
(provide build-parser)
|
|
|
|
(define (strip so)
|
|
(syntax-local-introduce
|
|
(datum->syntax-object
|
|
#f
|
|
(syntax-object->datum so)
|
|
so
|
|
so)))
|
|
|
|
(define (fix-check-syntax start terms prods precs ends)
|
|
(syntax-case prods ()
|
|
((_ (bind ((bound ...) x ...) ...) ...)
|
|
(let ((binds (syntax->list (syntax (bind ...))))
|
|
(bounds (cons start
|
|
(apply
|
|
append
|
|
(map syntax->list
|
|
(apply
|
|
append
|
|
(map syntax->list
|
|
(syntax->list (syntax (((bound ...) ...) ...)))))))))
|
|
(terms (get-term-list terms))
|
|
(precs (if precs
|
|
(syntax-case precs ()
|
|
((_ (__ term ...) ...)
|
|
(apply append (map syntax->list (syntax->list (syntax ((term ...) ...)))))))
|
|
null)))
|
|
`(if #f (let ,(map (lambda (bind)
|
|
`(,(strip bind) void))
|
|
(append terms binds))
|
|
(void ,@(append ends precs (map strip bounds)))))))))
|
|
|
|
(define (build-parser filename src-pos suppress input-terms start end assocs prods runtime)
|
|
(let* ((grammar (parse-input start end input-terms assocs prods runtime 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)))))
|
|
(let loop ((i 1))
|
|
(if (< i (vector-length table))
|
|
(let ((a (vector-ref table i)))
|
|
(vector-set! table i (cond
|
|
((accept? a) 'accept)
|
|
((shift? a) (- (shift-state a)))
|
|
((reduce? a) (vector (reduce-prod-num a)
|
|
(reduce-lhs-num a)
|
|
(reduce-rhs-length a)))
|
|
(else a)))
|
|
(loop (add1 i)))))
|
|
(values table
|
|
token-code
|
|
actions-code
|
|
(fix-check-syntax start input-terms prods assocs end))))
|
|
|
|
)
|