From a1bd7de97324810e61149f6e960ae2e52e595031 Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Thu, 22 Apr 2004 23:43:53 +0000 Subject: [PATCH] Fix for v299. original commit: 492e108ee78f92f37468534eb4468c953b0257b1 --- collects/parser-tools/lex.ss | 90 ++------------------- collects/parser-tools/private-lex/re.ss | 6 +- collects/parser-tools/private-yacc/table.ss | 7 +- collects/parser-tools/yacc.ss | 7 +- 4 files changed, 15 insertions(+), 95 deletions(-) diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss index 6f430fe..04bba9d 100644 --- a/collects/parser-tools/lex.ss +++ b/collects/parser-tools/lex.ss @@ -115,87 +115,7 @@ #f "Form should be (define-lex-abbrevs (name re) ...)" 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) (if (>= min max) @@ -219,8 +139,8 @@ #f)) (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?) + special-action special-error-action + has-special-comment-action? special-comment-action eof-action wrap?) (letrec ((lexer (lambda (ip) (unless (input-port? ip) @@ -235,9 +155,9 @@ ((eq? 'special first-char) (let* ((comment? #f) (error? #f) - (spec (with-handlers ((exn:special-comment? + (spec (with-handlers ((special-comment? (lambda (x) (set! comment? #t))) - (not-break-exn? + (exn:fail? (lambda (ex) (set! error? #t) ex))) (read-char-or-special ip)))) (cond diff --git a/collects/parser-tools/private-lex/re.ss b/collects/parser-tools/private-lex/re.ss index 60c3942..06e775c 100644 --- a/collects/parser-tools/private-lex/re.ss +++ b/collects/parser-tools/private-lex/re.ss @@ -11,6 +11,8 @@ andR-res negR-re re-nullable? re-index) + (define max-char-num #x7FFFFFFF) + ;; get-index : -> nat (define get-index (make-counter)) @@ -109,9 +111,9 @@ (`(^ ,crs ...) (let ((cs (->re `(: ,@crs) cache))) (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) - (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)))))) diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index 58b615e..11f487d 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -292,13 +292,12 @@ (resolve-prec-conflicts a table get-term get-prod num-terms num-non-terms) (if (not (string=? file "")) - (with-handlers [(exn:i/o:filesystem? + (with-handlers [(exn:fail:filesystem? (lambda (e) (fprintf (current-error-port) - "Cannot write debug output to file \"~a\". ~a~n" - (exn:i/o:filesystem-pathname e) - (exn:i/o:filesystem-detail e))))] + "Cannot write debug output to file \"~a\".~n" + file)))] (call-with-output-file file (lambda (port) (display-parser a table get-term get-non-term (send g get-prods) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 7f01663..ccb5a90 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -131,13 +131,12 @@ grammar stx))) (when (and yacc-output (not (string=? yacc-output ""))) - (with-handlers [(exn:i/o:filesystem? + (with-handlers [(exn:fail:filesystem? (lambda (e) (fprintf (current-error-port) - "Cannot write yacc-output to file \"~a\". ~a~n" - (exn:i/o:filesystem-pathname e) - (exn:i/o:filesystem-detail e))))] + "Cannot write yacc-output to file \"~a\"~n" + yacc-output)))] (call-with-output-file yacc-output (lambda (port) (display-yacc (syntax-object->datum grammar)