Fix for v299.

original commit: 492e108ee78f92f37468534eb4468c953b0257b1

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

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))))))
               
 

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)

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)