mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: 743eeb59fcf962813ba85cb3bdc20eb65fe71732
tokens
Scott Owens 23 years ago
parent 9c730a5f6e
commit bc38b81823
2 changed files with 195 additions and 169 deletions
Show Stats Download Patch File Download Diff File

162
collects/parser-tools/private-yacc/parser-builder.ss
Unescape Escape View File

@ -39,7 +39,7 @@
(append terms binds)) (append terms binds))
(void ,@(append ends precs (map strip bounds))))))))) (void ,@(append ends precs (map strip bounds)))))))))
(define (build-parser filename src-pos suppress error-expr input-terms start end assocs prods runtime src) (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)) (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
(table (build-table grammar filename suppress)) (table (build-table grammar filename suppress))
(table-code (table-code
@ -87,158 +87,10 @@
ht))) ht)))
(actions-code (actions-code
`(vector ,@(map prod-action (grammar-prods grammar)))) `(vector ,@(map prod-action (grammar-prods grammar)))))
(values table-code
token-code
actions-code
(fix-check-syntax start input-terms prods assocs end))))
(parser-code )
`(letrec ((err ,error-expr)
(ends ',end)
(table ,table-code)
(term-sym->index ,token-code)
(actions ,actions-code)
(input->token
(lambda (ip)
,(if src-pos
`(cond
((and (list? ip) (= 3 (length ip)))
(let ((tok (car ip)))
(cond
((symbol? tok) (make-token tok #f))
((token? tok) tok)
(else (raise-type-error 'parser
"(list (token or symbol) position position)"
0
ip)))))
(else
(raise-type-error 'parser
"(list (token or symbol) position position)"
0
ip)))
`(cond
((symbol? ip) (make-token ip #f))
((token? ip) ip)
(else (raise-type-error 'parser "token or symbol" 0 ip))))))
(reduce-stack
(lambda (s n v)
(if (> n 0)
,(if src-pos
`(reduce-stack (cddddr s) (sub1 n) `(,(cadr s) ,(caddr s) ,(cadddr s) ,@v))
`(reduce-stack (cddr s) (sub1 n) (cons (cadr s) v)))
(values s v))))
(fix-error
(lambda (stack tok ip get-token)
(letrec ((remove-input
(lambda ()
(if (memq (token-name tok) ends)
#f
(let ((a (find-action stack tok ip)))
(cond
((shift? a)
;; (printf "shift:~a~n" (shift-state a))
,(if src-pos
``(,(shift-state a)
,(if (token? ip) (token-value ip) #f)
,(cadr ip)
,(caddr ip)
,@stack)
``(,(shift-state a)
,(if (token? ip) (token-value ip) #f)
,@stack)))
(else
;; (printf "discard input:~a~n" tok)
(set! ip (get-token))
(set! tok (input->token ip))
(remove-input)))))))
(remove-states
(lambda ()
(let ((a (find-action stack (make-token 'error #f) #f)))
(cond
((shift? a)
;; (printf "shift:~a~n" (shift-state a))
(set! stack
,(if src-pos
``(,(shift-state a) ,#f ,(cadr ip) ,(caddr ip) ,@stack)
``(,(shift-state a) ,#f ,@stack)))
(remove-input))
(else
;; (printf "discard state:~a~n" (car stack))
(cond
((< (length stack) ,(if src-pos `5 `3))
(printf "Unable to shift error token~n")
#f)
(else
,(if src-pos
`(set! stack (cddddr stack))
`(set! stack (cddr stack)))
(remove-states)))))))))
(remove-states))))
(find-action
(lambda (stack tok ip)
(array2d-ref table
(car stack)
(hash-table-get term-sym->index
(token-name tok)
(lambda ()
,(if src-pos
`(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
`(err #t (token-name tok) (token-value tok)))
(raise-read-error (format "parser: got token of unknown type ~a" (token-name tok))
#f #f #f #f #f)))))))
(lambda (get-token)
(let parsing-loop ((stack (list 0))
(ip (get-token)))
(let* ((tok (input->token ip))
(action (find-action stack tok ip)))
(cond
((shift? action)
;; (printf "shift:~a~n" (shift-state action))
(let ((val (token-value tok)))
(parsing-loop ,(if src-pos
``(,(shift-state action) ,val ,(cadr ip) ,(caddr ip) ,@stack)
``(,(shift-state action) ,val ,@stack))
(get-token))))
((reduce? action)
;; (printf "reduce:~a~n" (reduce-prod-num action))
(let-values (((new-stack args)
(reduce-stack stack
(reduce-rhs-length action)
null)))
(let* ((A (reduce-lhs-num action))
(goto (array2d-ref table (car new-stack) A)))
(parsing-loop ,(if src-pos
``(,goto
,(apply
(vector-ref actions
(reduce-prod-num action))
args)
,(if (null? args)
(cadr ip)
(cadr args))
,(if (null? args)
(caddr ip)
(list-ref args (- (* (reduce-rhs-length action) 3) 1)))
,@new-stack)
``(,goto
,(apply
(vector-ref actions
(reduce-prod-num action))
args)
,@new-stack))
ip))))
((accept? action)
;; (printf "accept~n")
(cadr stack))
(else
,(if src-pos
`(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
`(err #t (token-name tok) (token-value tok)))
(let ((new-stack (fix-error stack tok ip get-token)))
(if new-stack
(parsing-loop new-stack (get-token))
(raise-read-error
"parser: Could not parse input"
#f #f #f #f #f)))))))))))
(datum->syntax-object
runtime
`(begin ,(fix-check-syntax start input-terms prods assocs end) ,parser-code)
src))))

198
collects/parser-tools/yacc.ss
Unescape Escape View File

@ -107,22 +107,196 @@
(raise-syntax-error #f "missing end declaration" stx)) (raise-syntax-error #f "missing end declaration" stx))
(if (not start) (if (not start)
(raise-syntax-error #f "missing start declaration" stx)) (raise-syntax-error #f "missing start declaration" stx))
(build-parser (if debug debug "") (let-values (((table term-sym->index actions check-syntax-fix)
src-pos (build-parser (if debug debug "")
suppress src-pos
error suppress
tokens tokens
start start
end end
precs precs
grammar grammar
#'here stx)))
stx))) (with-syntax ((check-syntax-fix check-syntax-fix)
(err error)
(ends end)
(table table)
(term-sym->index term-sym->index)
(actions actions)
(src-pos src-pos))
(syntax
(begin
check-syntax-fix
(parser-body err (quote ends) table term-sym->index actions src-pos)))))))
(_ (_
(raise-syntax-error (raise-syntax-error
#f #f
"parser must have the form (parser args ...)" "parser must have the form (parser args ...)"
stx)))) stx))))
(define (reduce-stack stack num ret-vals src-pos)
(cond
((> num 0)
(let* ((top-frame (car stack))
(ret-vals
(if src-pos
(cons (stack-frame-value top-frame)
(cons (stack-frame-start-pos top-frame)
(cons (stack-frame-end-pos top-frame)
ret-vals)))
(cons (stack-frame-value top-frame) ret-vals))))
(reduce-stack (cdr stack) (sub1 num) ret-vals src-pos)))
(else (values stack ret-vals))))
) (define-struct stack-frame (state value start-pos end-pos))
(define empty-stack (list (make-stack-frame 0 #f #f #f)))
(define (parser-body err ends table term-sym->index actions src-pos)
(letrec ((input->token
(lambda (ip)
(if src-pos
(cond
((and (list? ip) (= 3 (length ip)))
(let ((tok (car ip)))
(cond
((symbol? tok) (make-token tok #f))
((token? tok) tok)
(else (raise-type-error 'parser
"(list (token or symbol) position position)"
0
ip)))))
(else
(raise-type-error 'parser
"(list (token or symbol) position position)"
0
ip)))
(cond
((symbol? ip) (make-token ip #f))
((token? ip) ip)
(else (raise-type-error 'parser "token or symbol" 0 ip))))))
(fix-error
(lambda (stack tok ip get-token)
(letrec ((remove-input
(lambda ()
(if (memq (token-name tok) ends)
#f
(let ((a (find-action stack tok ip)))
(cond
((shift? a)
;; (printf "shift:~a~n" (shift-state a))
(cons (if src-pos
(make-stack-frame (shift-state a)
(if (token? ip) (token-value ip) #f)
(cadr ip)
(caddr ip))
(make-stack-frame (shift-state a)
(if (token? ip) (token-value ip) #f)
#f
#f))
stack))
(else
;; (printf "discard input:~a~n" tok)
(set! ip (get-token))
(set! tok (input->token ip))
(remove-input)))))))
(remove-states
(lambda ()
(let ((a (find-action stack (make-token 'error #f) #f)))
(cond
((shift? a)
;; (printf "shift:~a~n" (shift-state a))
(set! stack
(cons
(if src-pos
(make-stack-frame (shift-state a)
#f
(cadr ip)
(caddr ip))
(make-stack-frame (shift-state a)
#f
#f
#f))
stack))
(remove-input))
(else
;; (printf "discard state:~a~n" (car stack))
(cond
((< (length stack) 2)
(printf "Unable to shift error token~n")
#f)
(else
(set! stack (cdr stack))))))))))
(remove-states))))
(find-action
(lambda (stack tok ip)
(array2d-ref table
(stack-frame-state (car stack))
(hash-table-get term-sym->index
(token-name tok)
(lambda ()
(if src-pos
(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
(err #t (token-name tok) (token-value tok)))
(raise-read-error (format "parser: got token of unknown type ~a" (token-name tok))
#f #f #f #f #f)))))))
(lambda (get-token)
(let parsing-loop ((stack empty-stack)
(ip (get-token)))
(let* ((tok (input->token ip))
(action (find-action stack tok ip)))
(cond
((shift? action)
;; (printf "shift:~a~n" (shift-state action))
(let ((val (token-value tok)))
(parsing-loop (cons (if src-pos
(make-stack-frame (shift-state action)
val
(cadr ip)
(caddr ip))
(make-stack-frame (shift-state action)
val
#f
#f))
stack)
(get-token))))
((reduce? action)
;; (printf "reduce:~a~n" (reduce-prod-num action))
(let-values (((new-stack args)
(reduce-stack stack
(reduce-rhs-length action)
null
src-pos)))
(let* ((A (reduce-lhs-num action))
(goto (array2d-ref table (stack-frame-state (car new-stack)) A)))
(parsing-loop (cons
(if src-pos
(make-stack-frame goto
(apply (vector-ref actions (reduce-prod-num action)) args)
(if (null? args) (cadr ip) (cadr args))
(if (null? args)
(caddr ip)
(list-ref args (- (* (reduce-rhs-length action) 3) 1))))
(make-stack-frame goto
(apply (vector-ref actions (reduce-prod-num action)) args)
#f
#f))
new-stack)
ip))))
((accept? action)
;; (printf "accept~n")
(stack-frame-value (car stack)))
(else
(if src-pos
(err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
(err #t (token-name tok) (token-value tok)))
(let ((new-stack (fix-error stack tok ip get-token)))
(if new-stack
(parsing-loop new-stack (get-token))
(raise-read-error
"parser: Could not parse input"
#f #f #f #f #f))))))))))
)
Write Preview
Loading…
Cancel
Save