From fddf5e115f93d4adcc6e3836790dcfb489938728 Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Sun, 18 Apr 2004 21:10:11 +0000 Subject: [PATCH] *** empty log message *** original commit: 5c256671397865fcdae77cb7e6eeb8699a6398e6 --- collects/parser-tools/private-lex/deriv.ss | 12 ++++++++---- collects/parser-tools/private-lex/front.ss | 15 ++++++++------- collects/parser-tools/private-lex/re.ss | 21 ++++++++++++++------- 3 files changed, 30 insertions(+), 18 deletions(-) diff --git a/collects/parser-tools/private-lex/deriv.ss b/collects/parser-tools/private-lex/deriv.ss index 566f919..73b3058 100644 --- a/collects/parser-tools/private-lex/deriv.ss +++ b/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) diff --git a/collects/parser-tools/private-lex/front.ss b/collects/parser-tools/private-lex/front.ss index 97ea07e..260c803 100644 --- a/collects/parser-tools/private-lex/front.ss +++ b/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)))) ) diff --git a/collects/parser-tools/private-lex/re.ss b/collects/parser-tools/private-lex/re.ss index cdae42d..60c3942 100644 --- a/collects/parser-tools/private-lex/re.ss +++ b/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