*** empty log message ***

original commit: ca20d2a89326943989e4ae31bdd9a121eced73fa
tokens
Scott Owens 23 years ago
parent ba3e2af0f8
commit dc2805cf48

@ -117,6 +117,7 @@
(start-sym (syntax-object->datum start)) (start-sym (syntax-object->datum start))
(list-of-terms (list-of-terms
(syntax-case term-defs (tokens) (syntax-case term-defs (tokens)
((tokens term-def ...) ((tokens term-def ...)
@ -224,6 +225,7 @@
type))) type)))
(syntax->list (syntax (type ...)))) (syntax->list (syntax (type ...))))
(cdr (syntax-object->datum prec-decls)))))) (cdr (syntax-object->datum prec-decls))))))
(#f null)
(_ (_
(raise-syntax-error (raise-syntax-error
'parser-precedences 'parser-precedences

@ -43,14 +43,58 @@
(parser-code (parser-code
`(letrec ((err ,error-expr) `(letrec ((err ,error-expr)
(term-sym->index ,token-code) (err-state 0)
(table ,table-code) (table ,table-code)
(term-sym->index ,token-code)
(actions ,actions-code) (actions ,actions-code)
(reduce-stack (reduce-stack
(lambda (s n v) (lambda (s n v)
(if (> n 0) (if (> n 0)
(reduce-stack (cdr (cdr s)) (sub1 n) (cons (cadr s) v)) (reduce-stack (cddr s) (sub1 n) (cons (cadr s) v))
(values s v))))) (values s v))))
(fix-error
(lambda (stack ip get-token)
(let remove-states ()
(let ((a (find-action stack 'error)))
(cond
((shift? a)
(printf "shift:~a~n" (shift-state a))
(set! stack (cons (shift-state a) (cons #f stack))))
(else
(printf "discard-state:~a~n" (car stack))
(cond
((< (length stack) 3)
(printf "Unable to shift error token~n")
#f)
(else
(set! stack (cddr stack))
(remove-states)))))))
(let remove-input ()
(let ((a (find-action stack ip)))
(cond
((shift? a)
(printf "shift:~a~n" (shift-state a))
(cons (shift-state a)
(cons (if (token? ip)
(token-value ip)
#f)
stack)))
(else
(printf "discard-input:~a~n" (if (token? ip)
(token-name ip)
ip))
(set! ip (get-token))
(remove-input)))))))
(find-action
(lambda (stack tok)
(array2d-ref table
(car stack)
(hash-table-get term-sym->index
(if (token? tok)
(token-name tok)
tok)
err)))))
(lambda (get-token) (lambda (get-token)
(let loop ((stack (list 0)) (let loop ((stack (list 0))
(ip (get-token))) (ip (get-token)))
@ -58,13 +102,7 @@
(newline) (newline)
(display (if (token? ip) (token-name ip) ip)) (display (if (token? ip) (token-name ip) ip))
(newline) (newline)
(let* ((s (car stack)) (let ((action (find-action stack ip)))
(a (hash-table-get term-sym->index
(if (token? ip)
(token-name ip)
ip)
err))
(action (array2d-ref table s a)))
(cond (cond
((shift? action) ((shift? action)
(printf "shift:~a~n" (shift-state action)) (printf "shift:~a~n" (shift-state action))
@ -89,8 +127,14 @@
new-stack)) new-stack))
ip)))) ip))))
((accept? action) ((accept? action)
(printf "accept~n")) (printf "accept~n")
(else (err))))))))) (cadr stack))
(else
(err)
(let ((new-stack (fix-error stack ip get-token)))
(if new-stack
(loop new-stack (get-token))
(void)))))))))))
(datum->syntax-object (datum->syntax-object
runtime runtime
parser-code parser-code

@ -79,8 +79,10 @@
(syntax->list (syntax (args ...)))) (syntax->list (syntax (args ...))))
(if (not tokens) (if (not tokens)
(raise-syntax-error #f "missing tokens declaration" stx)) (raise-syntax-error #f "missing tokens declaration" stx))
(if (not grammar) (if (not error)
(raise-syntax-error #f "missing error declaration" stx)) (raise-syntax-error #f "missing error declaration" stx))
(if (not grammar)
(raise-syntax-error #f "missing grammar declaration" stx))
(if (not end) (if (not end)
(raise-syntax-error #f "missing end declaration" stx)) (raise-syntax-error #f "missing end declaration" stx))
(build-parser (if debug debug "") (build-parser (if debug debug "")

Loading…
Cancel
Save