*** empty log message ***

original commit: 5c256671397865fcdae77cb7e6eeb8699a6398e6

collects/parser-tools/private-lex/deriv.ss

@@ -58,14 +58,14 @@
               ((get-char-groups (->re `(& (* ,r1) (@ (* ,r2) "3") "4") c) #f)
                (list r1 r2 (->re "3" c) (->re "4" c)))
               )
-                                 
+  (define loc:member? is:member?)
   
   ;; deriveR : re char cache -> re
   (define (deriveR r c cache)
     (cond
       ((or (eq? r e) (eq? r z)) z)
       ((char-setR? r)
-       (if (is:member? c (char-setR-chars r)) e z))
+       (if (loc:member? c (char-setR-chars r)) e z))
       ((concatR? r)
        (let* ((r1 (concatR-re1 r))
               (r2 (concatR-re2 r))
@@ -180,6 +180,8 @@
   (define (get-key s)
     (map (lambda (x) (re-index (car x))) s))  
           
+  (define loc:partition is:partition)
+  
   ;; compute-chars : (list-of state) -> (list-of char-set)
   ;; Computed the sets of equivalent characters for taking the
   ;; derivative of the car of st.  Only one derivative per set need to be taken.
@@ -187,7 +189,7 @@
     (cond
       ((null? st) null)
       (else
-       (is:partition (map char-setR-chars
+       (loc:partition (map char-setR-chars
                           (apply append (map (lambda (x) (get-char-groups (car x) #f))
                                              (state-spec (car st)))))))))
   
@@ -210,6 +212,8 @@
   ;; The finals and transitions are sorted by state number, and duplicate free.
   (define-struct dfa (num-states start-state final-states/actions transitions) (make-inspector))
   
+  (define loc:get-integer is:get-integer)
+  
   ;; build-dfa : (list-of re-action) cache -> dfa
   (define (build-dfa rs cache)
     (let* ((transitions (make-hash-table))
@@ -243,7 +247,7 @@
           (else
            (let* ((state (car old-states))
                   (c (car cs))
-                  (new-re (derive (state-spec state) (is:get-integer c) cache)))
+                  (new-re (derive (state-spec state) (loc:get-integer c) cache)))
              (cond
                (new-re
                 (let* ((new-state? #f)

collects/parser-tools/private-lex/front.ss

@@ -22,6 +22,7 @@
 ;  (define (dfa->1d-table dfa)
 ;    (let (
   
+  (define loc:foldr is:foldr)
   
   ;; dfa->2d-table : dfa -> (same as build-lexer)
   (define (dfa->2d-table dfa)
@@ -38,7 +39,7 @@
          (let ((from-state (car trans)))
            (for-each (lambda (chars/to)
                        (let ((to-state (cdr chars/to)))
-                         (is:foldr (lambda (char _)
+                         (loc:foldr (lambda (char _)
                                      (vector-set! char-table
                                                   (bitwise-ior 
                                                    char
@@ -98,13 +99,13 @@
 
            (cache (make-cache))
            
-           (re-acts (map (lambda (s-re-act)
-                           (cons (->re (car s-re-act) cache)
-                                 (cdr s-re-act)))
-                         s-re-acts))
+           (re-acts (time (map (lambda (s-re-act)
+                                 (cons (->re (car s-re-act) cache)
+                                       (cdr s-re-act)))
+                               s-re-acts)))
            
-           (dfa (build-dfa re-acts cache)))
+           (dfa (time (build-dfa re-acts cache))))
       ;(print-dfa dfa)
       ;(printf "states: ~a~n" (dfa-num-states dfa))
-      (values (dfa->2d-table dfa) (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa))))
+      (values (time (dfa->2d-table dfa)) (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa))))
   )

collects/parser-tools/private-lex/re.ss

@@ -62,10 +62,15 @@
   ;;  The null or `(:) means match nothing.  The null carat `(^) means match
   ;;  any character.  The null intersection `(&) means match string.)
 
+  (define loc:make-range is:make-range)
+  (define loc:union is:union)
+  (define loc:split is:split)
+  (define loc:complement is:complement)
+  
   ;; ->re : s-re cache -> re
   (define (->re exp cache)
     (match exp
-      ((? char?) (build-char-set (is:make-range (char->integer exp)) cache))
+      ((? char?) (build-char-set (loc:make-range (char->integer exp)) cache))
       ((? string?) (->re `(@ ,@(string->list exp)) cache))
       ((? re?) exp)
       (`(epsilon) (build-epsilon))
@@ -80,12 +85,12 @@
               (build-or (list e c) cache))))
       (`(: ,rs ...)
         (build-or (flatten-res (map (lambda (r) (->re r cache)) rs)
-                               orR? orR-res is:union cache)
+                               orR? orR-res loc:union cache)
                   cache))
       (`(& ,rs ...)
         (build-and (flatten-res (map (lambda (r) (->re r cache)) rs)
                                 andR? andR-res (lambda (a b)
-                                                 (let-values (((i _ __) (is:split a b))) i))
+                                                 (let-values (((i _ __) (loc:split a b))) i))
                                 cache)
                    cache))
       (`(~ ,r)
@@ -99,14 +104,14 @@
         (let ((i1 (char->integer (if (string? c1) (string-ref c1 0) c1)))
               (i2 (char->integer (if (string? c2) (string-ref c2 0) c2))))
           (if (<= i1 i2)
-              (build-char-set (is:make-range i1 i2) cache)
+              (build-char-set (loc:make-range i1 i2) cache)
               z)))
       (`(^ ,crs ...)
         (let ((cs (->re `(: ,@crs) cache)))
           (cond
-            ((zeroR? cs) (build-char-set (is:make-range 0 255) cache))
+            ((zeroR? cs) (build-char-set (loc:make-range 0 255) cache))
             ((char-setR? cs)
-             (build-char-set (is:complement (char-setR-chars cs) 0 255) cache))
+             (build-char-set (loc:complement (char-setR-chars cs) 0 255) cache))
             (else z))))))
               
 
@@ -140,9 +145,11 @@
   
   (define (build-zero) z)
     
+  (define loc:integer-set-contents is:integer-set-contents)
+  
   ;; build-char-set : char-set cache -> re
   (define (build-char-set cs cache)
-    (let ((l (is:integer-set-contents cs)))
+    (let ((l (loc:integer-set-contents cs)))
       (cond
         ((null? l) z)
         (else