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

65
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,21 +37,22 @@
(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
(char (next-char lb)) (char (next-char lb))
;; action for the longest match seen thus far ;; action for the longest match seen thus far
;; including a match at the current state ;; including a match at the current state
(longest-match-action (longest-match-action
(vector-ref actions start-state)) (vector-ref actions start-state))
;; how many characters have been read ;; how many characters have been read
;; including the one just read ;; including the one just read
(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
((eof-object? char) ((eof-object? char)
@ -70,16 +71,17 @@
longest-match-action longest-match-action
length)) length))
(else (else
(loop next-state (let ((act (vector-ref actions next-state)))
(next-char lb) (lexer-loop next-state
(if (vector-ref actions next-state) (next-char lb)
(vector-ref actions next-state) (if act
longest-match-action) act
(add1 length) longest-match-action)
(if (vector-ref actions next-state) (add1 length)
length (if act
longest-match-length) length
pos)))))))))) longest-match-length)
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)

95
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,37 +71,41 @@
(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 (let ((a (find-action stack ip)))
((shift? a) (cond
(printf "shift:~a~n" (shift-state a)) ((shift? a)
(set! stack (cons (shift-state a) (cons #f stack)))) ;; (printf "shift:~a~n" (shift-state a))
(else (cons (shift-state a)
(printf "discard-state:~a~n" (car stack)) (cons (if (token? ip)
(cond (token-value ip)
((< (length stack) 3) #f)
(printf "Unable to shift error token~n") stack)))
#f) (else
(else (printf "discard-input:~a~n" (if (token? ip)
(set! stack (cddr stack)) (token-name ip)
(remove-states))))))) ip))
(let remove-input () (set! ip (get-token))
(let ((a (find-action stack ip))) (remove-input))))))
(cond (remove-states
((shift? a) (lambda ()
(printf "shift:~a~n" (shift-state a)) (let ((a (find-action stack 'error)))
(cons (shift-state a) (cond
(cons (if (token? ip) ((shift? a)
(token-value ip) ;; (printf "shift:~a~n" (shift-state a))
#f) (set! stack (cons (shift-state a) (cons #f stack)))
stack))) (remove-input))
(else (else
(printf "discard-input:~a~n" (if (token? ip) ;; (printf "discard-state:~a~n" (car stack))
(token-name ip) (cond
ip)) ((< (length stack) 3)
(set! ip (get-token)) (printf "Unable to shift error token~n")
(remove-input))))))) #f)
(else
(set! stack (cddr stack))
(remove-states)))))))))
(remove-states))))
(find-action (find-action
(lambda (stack tok) (lambda (stack tok)
@ -113,8 +117,8 @@
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)
;;(display (if (token? ip) (token-name ip) ip)) ;;(display (if (token? ip) (token-name ip) ip))
@ -126,8 +130,8 @@
(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))
(let-values (((new-stack args) (let-values (((new-stack args)
@ -136,13 +140,13 @@
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))
args) args)
new-stack)) new-stack))
ip)))) ip))))
((accept? action) ((accept? action)
;; (printf "accept~n") ;; (printf "accept~n")
(cadr stack)) (cadr stack))
@ -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