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

*** empty log message ***

Browse Source 
original commit: 61c73a6a8496b6340326e3396d29289fd5aacdce
tokens
Scott Owens 23 years ago
parent 6b9c407e57
commit 53140f51b2
3 changed files with 81 additions and 81 deletions
Show Stats Download Patch File Download Diff File

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

@ -10,7 +10,7 @@
(provide lex define-lex-abbrev define-lex-abbrevs (provide lex define-lex-abbrev define-lex-abbrevs
make-lex-buf make-lex-buf
get-position position-offset position-line position-col position? get-position position-offset position-line position-col position?
define-tokens define-empty-tokens token-value token-name token?) define-tokens define-empty-tokens)
(define-syntax lex (define-syntax lex
@ -27,9 +27,9 @@
(lambda () (lambda ()
end-pos) end-pos)
(lambda () (lambda ()
(list->string (reverse (filter (lambda (x) (if (char? (car match))
(char? x)) (list->string (reverse match))
match)))) (list->string (reverse (cdr match)))))
lb))))) lb)))))
(lambda (lb) (lambda (lb)
(unless (lex-buffer? lb) (unless (lex-buffer? lb)
@ -37,7 +37,7 @@
(format (format
"Lexer expects argument of type lex-buf; given ~a" lb))) "Lexer expects argument of type lex-buf; given ~a" lb)))
(let ((first-pos (get-position lb))) (let ((first-pos (get-position lb)))
(let loop ( (let lexer-loop (
;; current-state ;; current-state
(state start-state) (state start-state)
;; the character to transition on ;; the character to transition on
@ -51,6 +51,7 @@
(length 1) (length 1)
;; how many characters are in the longest match ;; how many characters are in the longest match
(longest-match-length 0) (longest-match-length 0)
;;(end-pos first-pos))
(end-pos first-pos)) (end-pos first-pos))
(let ((next-state (let ((next-state
(cond (cond
@ -70,16 +71,17 @@
longest-match-action longest-match-action
length)) length))
(else (else
(loop next-state (let ((act (vector-ref actions next-state)))
(lexer-loop next-state
(next-char lb) (next-char lb)
(if (vector-ref actions next-state) (if act
(vector-ref actions next-state) act
longest-match-action) longest-match-action)
(add1 length) (add1 length)
(if (vector-ref actions next-state) (if act
length length
longest-match-length) longest-match-length)
pos)))))))))) pos)))))))))))
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
((_ (re act) ...) ((_ (re act) ...)
@ -224,8 +226,3 @@
) )

2
collects/parser-tools/private-lex/token.ss
Unescape Escape View File

@ -7,7 +7,7 @@
(provide define-tokens define-empty-tokens token-name token-value token?) (provide define-tokens define-empty-tokens token-name token-value token?)
(define-struct token (name value)) (define-struct token (name value) (make-inspector))
(define-syntax define-tokens (define-syntax define-tokens
(lambda (stx) (lambda (stx)

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

@ -14,7 +14,7 @@
(table-code (table-code
`((lambda (table-list) `((lambda (table-list)
(let ((v (list->vector table-list))) (let ((v (list->vector table-list)))
(let loop ((i 0)) (let build-table-loop ((i 0))
(cond (cond
((< i (vector-length v)) ((< i (vector-length v))
(let ((vi (vector-ref v i))) (let ((vi (vector-ref v i)))
@ -27,7 +27,7 @@
((eq? 'r (car vi)) ((eq? 'r (car vi))
(make-reduce (cadr vi) (caddr vi) (cadddr vi))) (make-reduce (cadr vi) (caddr vi) (cadddr vi)))
((eq? 'a (car vi)) (make-accept))))))) ((eq? 'a (car vi)) (make-accept)))))))
(loop (add1 i))) (build-table-loop (add1 i)))
(else v))))) (else v)))))
(quote (quote
,(map (lambda (action) ,(map (lambda (action)
@ -71,26 +71,12 @@
(values s v)))) (values s v))))
(fix-error (fix-error
(lambda (stack ip get-token) (lambda (stack ip get-token)
(let remove-states () (letrec ((remove-input
(let ((a (find-action stack 'error))) (lambda ()
(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))) (let ((a (find-action stack 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) (cons (shift-state a)
(cons (if (token? ip) (cons (if (token? ip)
(token-value ip) (token-value ip)
@ -101,7 +87,25 @@
(token-name ip) (token-name ip)
ip)) ip))
(set! ip (get-token)) (set! ip (get-token))
(remove-input))))))) (remove-input))))))
(remove-states
(lambda ()
(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)))
(remove-input))
(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)))))))))
(remove-states))))
(find-action (find-action
(lambda (stack tok) (lambda (stack tok)
@ -113,7 +117,7 @@
tok) tok)
err))))) err)))))
(lambda (get-token) (lambda (get-token)
(let loop ((stack (list 0)) (let parsing-loop ((stack (list 0))
(ip (get-token))) (ip (get-token)))
;;(display stack) ;;(display stack)
;;(newline) ;;(newline)
@ -126,7 +130,7 @@
(let ((val (if (token? ip) (let ((val (if (token? ip)
(token-value ip) (token-value ip)
#f))) #f)))
(loop (cons (shift-state action) (cons val stack)) (parsing-loop (cons (shift-state action) (cons val stack))
(get-token)))) (get-token))))
((reduce? action) ((reduce? action)
;; (printf "reduce:~a~n" (reduce-prod-num action)) ;; (printf "reduce:~a~n" (reduce-prod-num action))
@ -136,7 +140,7 @@
null))) null)))
(let* ((A (reduce-lhs-num action)) (let* ((A (reduce-lhs-num action))
(goto (array2d-ref table (car new-stack) A))) (goto (array2d-ref table (car new-stack) A)))
(loop (cons goto (parsing-loop (cons goto
(cons (apply (cons (apply
(vector-ref actions (vector-ref actions
(reduce-prod-num action)) (reduce-prod-num action))
@ -150,10 +154,9 @@
(err) (err)
(let ((new-stack (fix-error stack ip get-token))) (let ((new-stack (fix-error stack ip get-token)))
(if new-stack (if new-stack
(loop new-stack (get-token)) (parsing-loop new-stack (get-token))
(void))))))))))) (void)))))))))))
(datum->syntax-object (datum->syntax-object
runtime runtime
parser-code parser-code
src)))) src))))
Write Preview
Loading…
Cancel
Save