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

Fix for v299.

Browse Source 
original commit: 492e108ee78f92f37468534eb4468c953b0257b1
tokens
Scott Owens 20 years ago
parent 81f3fd0bd2
commit a1bd7de973
4 changed files with 15 additions and 95 deletions
Show Stats Download Patch File Download Diff File

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

@ -115,87 +115,7 @@
#f #f
"Form should be (define-lex-abbrevs (name re) ...)" "Form should be (define-lex-abbrevs (name re) ...)"
stx)))) stx))))
#;
(define (lexer-body start-state trans-table actions no-lookahead
special-action special-error-action
has-special-comment-action? special-comment-action eof-action wrap?)
(letrec ((lexer
(lambda (ip)
(unless (input-port? ip)
(raise-type-error
'lexer
"input-port"
0
ip))
(let ((first-pos (get-position ip))
(first-char (peek-char-or-special ip 0)))
(cond
((eq? 'special first-char)
(let* ((comment? #f)
(error? #f)
(spec (with-handlers ((exn:special-comment?
(lambda (x) (set! comment? #t)))
(not-break-exn?
(lambda (ex) (set! error? #t) ex)))
(read-char-or-special ip))))
(cond
((and comment? (not has-special-comment-action?))
(lexer ip))
(else
(do-match ip first-pos (cond
(comment? special-comment-action)
(error? special-error-action)
(else special-action))
spec wrap?)))))
((eof-object? first-char)
(do-match ip first-pos eof-action (read-char-or-special ip) wrap?))
(else
(let lexer-loop (
;; current-state
(state start-state)
;; the character to transition on
(char first-char)
;; 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 1))
(let ((next-state
(cond
((eof-object? char) #f)
((eq? char 'special) #f)
(else
(vector-ref
trans-table
(+ (char->integer char) (* 256 state)))))))
(cond
((not next-state)
(check-match ip first-pos longest-match-length
length longest-match-action wrap?))
((vector-ref no-lookahead next-state)
(let ((act (vector-ref actions next-state)))
(check-match ip
first-pos
(if act length longest-match-length)
length
(if act act longest-match-action)
wrap?)))
(else
(let ((act (vector-ref actions next-state)))
(lexer-loop next-state
(peek-char-or-special ip length)
(if act
act
longest-match-action)
(add1 length)
(if act
length
longest-match-length)))))))))))))
lexer))
(define (get-next-state-helper char min max table) (define (get-next-state-helper char min max table)
(if (>= min max) (if (>= min max)
@ -219,8 +139,8 @@
#f)) #f))
(define (lexer-body start-state trans-table actions no-lookahead (define (lexer-body start-state trans-table actions no-lookahead
special-action special-error-action special-action special-error-action
has-special-comment-action? special-comment-action eof-action wrap?) has-special-comment-action? special-comment-action eof-action wrap?)
(letrec ((lexer (letrec ((lexer
(lambda (ip) (lambda (ip)
(unless (input-port? ip) (unless (input-port? ip)
@ -235,9 +155,9 @@
((eq? 'special first-char) ((eq? 'special first-char)
(let* ((comment? #f) (let* ((comment? #f)
(error? #f) (error? #f)
(spec (with-handlers ((exn:special-comment? (spec (with-handlers ((special-comment?
(lambda (x) (set! comment? #t))) (lambda (x) (set! comment? #t)))
(not-break-exn? (exn:fail?
(lambda (ex) (set! error? #t) ex))) (lambda (ex) (set! error? #t) ex)))
(read-char-or-special ip)))) (read-char-or-special ip))))
(cond (cond

6
collects/parser-tools/private-lex/re.ss
Unescape Escape View File

@ -11,6 +11,8 @@
andR-res negR-re andR-res negR-re
re-nullable? re-index) re-nullable? re-index)
(define max-char-num #x7FFFFFFF)
;; get-index : -> nat ;; get-index : -> nat
(define get-index (make-counter)) (define get-index (make-counter))
@ -109,9 +111,9 @@
(`(^ ,crs ...) (`(^ ,crs ...)
(let ((cs (->re `(: ,@crs) cache))) (let ((cs (->re `(: ,@crs) cache)))
(cond (cond
((zeroR? cs) (build-char-set (loc:make-range 0 255) cache)) ((zeroR? cs) (build-char-set (loc:make-range 0 max-char-num) cache))
((char-setR? cs) ((char-setR? cs)
(build-char-set (loc:complement (char-setR-chars cs) 0 255) cache)) (build-char-set (loc:complement (char-setR-chars cs) 0 max-char-num) cache))
(else z)))))) (else z))))))

7
collects/parser-tools/private-yacc/table.ss
Unescape Escape View File

@ -292,13 +292,12 @@
(resolve-prec-conflicts a table get-term get-prod num-terms (resolve-prec-conflicts a table get-term get-prod num-terms
num-non-terms) num-non-terms)
(if (not (string=? file "")) (if (not (string=? file ""))
(with-handlers [(exn:i/o:filesystem? (with-handlers [(exn:fail:filesystem?
(lambda (e) (lambda (e)
(fprintf (fprintf
(current-error-port) (current-error-port)
"Cannot write debug output to file \"~a\". ~a~n" "Cannot write debug output to file \"~a\".~n"
(exn:i/o:filesystem-pathname e) file)))]
(exn:i/o:filesystem-detail e))))]
(call-with-output-file file (call-with-output-file file
(lambda (port) (lambda (port)
(display-parser a table get-term get-non-term (send g get-prods) (display-parser a table get-term get-non-term (send g get-prods)

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

@ -131,13 +131,12 @@
grammar grammar
stx))) stx)))
(when (and yacc-output (not (string=? yacc-output ""))) (when (and yacc-output (not (string=? yacc-output "")))
(with-handlers [(exn:i/o:filesystem? (with-handlers [(exn:fail:filesystem?
(lambda (e) (lambda (e)
(fprintf (fprintf
(current-error-port) (current-error-port)
"Cannot write yacc-output to file \"~a\". ~a~n" "Cannot write yacc-output to file \"~a\"~n"
(exn:i/o:filesystem-pathname e) yacc-output)))]
(exn:i/o:filesystem-detail e))))]
(call-with-output-file yacc-output (call-with-output-file yacc-output
(lambda (port) (lambda (port)
(display-yacc (syntax-object->datum grammar) (display-yacc (syntax-object->datum grammar)

Write Preview
Loading…
Cancel
Save