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
make-lex-buf
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
@ -27,9 +27,9 @@
(lambda ()
end-pos)
(lambda ()
(list->string (reverse (filter (lambda (x)
(char? x))
match))))
(if (char? (car match))
(list->string (reverse match))
(list->string (reverse (cdr match)))))
lb)))))
(lambda (lb)
(unless (lex-buffer? lb)
@ -37,21 +37,22 @@
(format
"Lexer expects argument of type lex-buf; given ~a" lb)))
(let ((first-pos (get-position lb)))
(let loop (
;; current-state
(state start-state)
;; the character to transition on
(char (next-char lb))
;; action for the longest match seen thus far
;; including a match at the current state
(longest-match-action
(vector-ref actions start-state))
;; how many characters have been read
;; including the one just read
(length 1)
;; how many characters are in the longest match
(longest-match-length 0)
(end-pos first-pos))
(let lexer-loop (
;; current-state
(state start-state)
;; the character to transition on
(char (next-char lb))
;; action for the longest match seen thus far
;; including a match at the current state
(longest-match-action
(vector-ref actions start-state))
;; how many characters have been read
;; including the one just read
(length 1)
;; how many characters are in the longest match
(longest-match-length 0)
;;(end-pos first-pos))
(end-pos first-pos))
(let ((next-state
(cond
((eof-object? char)
@ -70,16 +71,17 @@
longest-match-action
length))
(else
(loop next-state
(next-char lb)
(if (vector-ref actions next-state)
(vector-ref actions next-state)
longest-match-action)
(add1 length)
(if (vector-ref actions next-state)
length
longest-match-length)
pos))))))))))
(let ((act (vector-ref actions next-state)))
(lexer-loop next-state
(next-char lb)
(if act
act
longest-match-action)
(add1 length)
(if act
length
longest-match-length)
pos)))))))))))
(lambda (stx)
(syntax-case stx ()
((_ (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?)
(define-struct token (name value))
(define-struct token (name value) (make-inspector))
(define-syntax define-tokens
(lambda (stx)

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

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