*** empty log message ***

original commit: 75b895669160a757c30554560b70a12913d743c8

collects/parser-tools/lex.ss

@@ -7,7 +7,8 @@
                       "private-lex/structs.ss")
 
   (require (lib "readerr.ss" "syntax")
-           "private-lex/token.ss")
+           "private-lex/token.ss"
+	   (lib "cffi.ss" "compiler"))
 
   (provide lexer lexer-src-pos define-lex-abbrev define-lex-abbrevs
 	   make-lex-buf
@@ -15,6 +16,33 @@
            define-tokens define-empty-tokens)
   
   (define-syntaxes (lexer lexer-src-pos)
+    (let ((build-lexer
+           (lambda (wrap?)
+             (lambda (stx)
+               (syntax-case stx ()
+                 ((_)
+                  (raise-syntax-error #f "empty lexer is not allowed" stx))
+                 ((_ re-act ...)
+                  (begin
+                    (for-each
+                     (lambda (x)
+                       (syntax-case x ()
+                         ((re act) (void))
+                         (_ (raise-syntax-error 'lexer 
+                                                "expects regular expression / action pairs"
+                                                x))))
+                     (syntax->list (syntax (re-act ...))))
+                    (let ((table (generate-table (syntax (re-act ...)) stx)))
+                      (with-syntax ((code (compile-table table))
+                                    (actions-stx `(vector ,@(vector->list (table-actions table))))
+                                    (wrap? wrap?))
+                        (syntax
+                         (compiled-lexer-body code actions-stx wrap?)))))))))))
+      (values
+       (build-lexer #f)
+       (build-lexer #t))))
+
+  (define-syntaxes (lexer-old lexer-src-pos-old)
     (let ((build-lexer
 	   (lambda (wrap?)
 	     (lambda (stx)
@@ -49,7 +77,6 @@
        (build-lexer #f)
        (build-lexer #t))))
 
-  
   (define-syntax (define-lex-abbrev stx)
     (syntax-case stx ()
       ((_ name re)
@@ -86,6 +113,19 @@
         "Form should be (define-lex-abbrevs (name re) ...)"
         stx))))
 
+  (define (compiled-lexer-body lexer actions wrap?)
+    (lambda (lb)
+      (unless (lex-buffer? lb)
+        (raise-type-error 
+         'lexer 
+         "lex-buf"
+         0
+         lb))
+      (let ((first-pos (get-position lb)))
+        (let-values (((longest-match-length longest-match-action)
+                      (lexer lb next-char)))
+          (do-match lb first-pos longest-match-length (vector-ref actions longest-match-action) wrap?)))))
+  
   (define (lexer-body start-state trans-table eof-table actions no-lookahead wrap?)
     (lambda (lb)
       (unless (lex-buffer? lb)