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 ;; c = char | eof
;; lex-buf = ;; lex-buf =
;; (make-lex-buffer input-port (c list) (c list) int int int (int list)) ;; (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)) (define-struct lex-buffer (ip from to offset line col line-lengths tab-skips has-seen-eof?))
;; make-lex-buf: input-port -> lex-buf ;; make-lex-buf: input-port -> lex-buf
(define make-lex-buf (define make-lex-buf
@ -74,7 +74,7 @@
((not (input-port? ip)) ((not (input-port? ip))
(raise-type-error 'make-lex-buf "input-port" 0 ip)) (raise-type-error 'make-lex-buf "input-port" 0 ip))
(else (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) ((ip offsets)
(cond (cond
((not (input-port? ip)) ((not (input-port? ip))
@ -85,12 +85,19 @@
(not (andmap (lambda (x) (>= x 0)) offsets))) (not (andmap (lambda (x) (>= x 0)) offsets)))
(raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets)) (raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets))
(else (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) (define (get-next lb)
(cond (cond
((null? (lex-buffer-from lb)) ((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 (else
(begin0 (begin0
(car (lex-buffer-from lb)) (car (lex-buffer-from lb))

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

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

Write Preview
Loading…
Cancel
Save