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

*** empty log message ***

Browse Source 
original commit: 5c5088e25177f4d087a86edf98568918e020e753
tokens
Scott Owens 23 years ago
parent bc38b81823
commit 036a5f5104
1 changed files with 21 additions and 15 deletions
Show Stats Download Patch File Download Diff File

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

@ -152,10 +152,12 @@
(define empty-stack (list (make-stack-frame 0 #f #f #f))) (define empty-stack (list (make-stack-frame 0 #f #f #f)))
(define (false-thunk) #f)
(define (parser-body err ends table term-sym->index actions src-pos) (define (parser-body err ends table term-sym->index actions src-pos)
(letrec ((input->token (letrec ((input->token
(lambda (ip)
(if src-pos (if src-pos
(lambda (ip)
(cond (cond
((and (list? ip) (= 3 (length ip))) ((and (list? ip) (= 3 (length ip)))
(let ((tok (car ip))) (let ((tok (car ip)))
@ -170,7 +172,8 @@
(raise-type-error 'parser (raise-type-error 'parser
"(list (token or symbol) position position)" "(list (token or symbol) position position)"
0 0
ip))) ip))))
(lambda (ip)
(cond (cond
((symbol? ip) (make-token ip #f)) ((symbol? ip) (make-token ip #f))
((token? ip) ip) ((token? ip) ip)
@ -203,7 +206,7 @@
(remove-input))))))) (remove-input)))))))
(remove-states (remove-states
(lambda () (lambda ()
(let ((a (find-action stack (make-token 'error #f) #f))) (let ((a (find-action stack (make-token 'error #f) ip)))
(cond (cond
((shift? a) ((shift? a)
;; (printf "shift:~a~n" (shift-state a)) ;; (printf "shift:~a~n" (shift-state a))
@ -232,11 +235,14 @@
(find-action (find-action
(lambda (stack tok ip) (lambda (stack tok ip)
(let ((token-index (hash-table-get term-sym->index
(token-name tok)
false-thunk)))
(if token-index
(array2d-ref table (array2d-ref table
(stack-frame-state (car stack)) (stack-frame-state (car stack))
(hash-table-get term-sym->index token-index)
(token-name tok) (begin
(lambda ()
(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)))

Write Preview
Loading…
Cancel
Save