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

*** empty log message ***

Browse Source 
original commit: 27123e599ff20f7e84eef5417353d102b4923b57
tokens
Scott Owens 23 years ago
parent 8b3242a26a
commit 85a29c420a
2 changed files with 67 additions and 48 deletions
Show Stats Download Patch File Download Diff File

17
collects/parser-tools/lex.ss
Unescape Escape View File

@ -63,8 +63,8 @@
;; c = char | eof
;; lex-buf =
;; (make-lex-buffer input-port (c list) (c list) int int int (int list))
(define-struct lex-buffer (ip from to offset line col line-lengths tab-skips))
;; (make-lex-buffer input-port (c list) (c list) int int int (int list) boolean)
(define-struct lex-buffer (ip from to offset line col line-lengths tab-skips has-seen-eof?))
;; make-lex-buf: input-port -> lex-buf
(define make-lex-buf
@ -74,7 +74,7 @@
((not (input-port? ip))
(raise-type-error 'make-lex-buf "input-port" 0 ip))
(else
(make-lex-buffer ip null null 1 1 1 null null))))
(make-lex-buffer ip null null 1 1 1 null null #f))))
((ip offsets)
(cond
((not (input-port? ip))
@ -85,12 +85,19 @@
(not (andmap (lambda (x) (>= x 0)) offsets)))
(raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets))
(else
(make-lex-buffer ip null null (caddr offsets) (car offsets) (cadr offsets) null null))))))
(make-lex-buffer ip null null (caddr offsets) (car offsets) (cadr offsets) null null #f))))))
(define (get-next lb)
(cond
((null? (lex-buffer-from lb))
(read-char (lex-buffer-ip lb)))
(let ((res (read-char (lex-buffer-ip lb))))
(if (eof-object? res)
(if (lex-buffer-has-seen-eof? lb)
(raise-read-error
(format "lex-buf: No characters left in input stream")
#f #f #f #f #f)
(set-lex-buffer-has-seen-eof?! lb #t)))
res))
(else
(begin0
(car (lex-buffer-from lb))

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

@ -90,6 +90,28 @@
(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)
@ -98,45 +120,53 @@
`(reduce-stack (cddr s) (sub1 n) (cons (cadr s) v)))
(values s v))))
(fix-error
(lambda (stack ip get-token)
(lambda (stack tok ip get-token)
(letrec ((remove-input
(lambda ()
(let ((a (find-action stack ip)))
(let ((a (find-action stack tok ip)))
(cond
((shift? a)
;; (printf "shift:~a~n" (shift-state a))
(cons (shift-state a)
(cons (if (token? ip)
(token-value ip)
#f)
stack)))
,(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" (if (token? ip)
(token-name ip)
ip))
(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 'error)))
(let ((a (find-action stack 'error #f)))
(cond
((shift? a)
;; (printf "shift:~a~n" (shift-state a))
(set! stack (cons (shift-state a) (cons #f stack)))
(remove-input))
(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))
;; (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)))))))))
((< (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 ,@(if src-pos `(ip) `()))
(lambda (stack tok ip)
(array2d-ref table
(car stack)
(hash-table-get term-sym->index
@ -150,26 +180,8 @@
(lambda (get-token)
(let parsing-loop ((stack (list 0))
(ip (get-token)))
(let* ((tok ,(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)))))
(action (find-action stack tok ,@(if src-pos `(ip) `()))))
(let* ((tok (input->token ip))
(action (find-action stack tok ip)))
(cond
((shift? action)
;; (printf "shift:~a~n" (shift-state action))
@ -196,7 +208,7 @@
(cadr ip)
(cadr args))
,(if (null? args)
(cadr ip)
(caddr ip)
(list-ref args (- (* (reduce-rhs-length action) 3) 1)))
,@new-stack)
``(,goto
@ -213,7 +225,7 @@
,(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 ip get-token)))
(let ((new-stack (fix-error stack tok ip get-token)))
(if new-stack
(parsing-loop new-stack (get-token))
(raise-read-error

Write Preview
Loading…
Cancel
Save