Refactor regexp-rules to allow prefix arguments.

diff --git a/src/runtime/regexp-rules.scm b/src/runtime/regexp-rules.scm
index 61c26d96ac615ecb52e08df78bbeb3c388a91d5b..12b882ea5e271eec4706fa4d5909ddb48884d6c8 100644 (file)
--- a/src/runtime/regexp-rules.scm
+++ b/src/runtime/regexp-rules.scm
@@ -58,23 +58,42 @@ USA.
       (char? object)
       (boolean? object)))
 
-(define (pattern-rule pattern operation #!optional guard-pred)
-  (let ((predicate (pattern->predicate pattern 'pattern-rule))
+(define (pattern-rule extra-args pattern operation #!optional guard-pred)
+  (guarantee exact-nonnegative-integer? extra-args 'pattern-rule)
+  (let ((pattern-pred (pattern->predicate pattern 'pattern-rule))
        (guard-pred (if (default-object? guard-pred) #f guard-pred)))
     (receive (wrapper arity)
-       (pattern-calling-convention pattern 'pattern-rule)
+       (pattern-calling-convention pattern extra-args 'pattern-rule)
       (guarantee-procedure-of-arity operation arity 'pattern-rule)
       (if guard-pred
          (guarantee-procedure-of-arity guard-pred arity 'pattern-rule))
       (general-rule pattern
                    (if guard-pred
-                       (let ((wrapped (wrapper guard-pred)))
-                         (lambda (object)
-                           (and (predicate object)
-                                (wrapped object))))
-                       predicate)
+                       (join-preds extra-args
+                                   pattern-pred
+                                   (wrapper guard-pred))
+                       (wrap-pattern-pred extra-args pattern-pred))
                    (wrapper operation)))))
 
+(define (join-preds extra-args pattern-pred guard-pred)
+  (case extra-args
+    ((0)
+     (lambda (object)
+       (and (pattern-pred object)
+           (guard-pred object))))
+    ((1)
+     (lambda (arg object)
+       (and (pattern-pred object)
+           (guard-pred arg object))))
+    (else
+     (error "Unsupported extra-args:" extra-args))))
+
+(define (wrap-pattern-pred extra-args predicate)
+  (case extra-args
+    ((0) predicate)
+    ((1) (lambda (arg object) (declare (ignore arg)) (predicate object)))
+    (else (error "Unsupported extra-args:" extra-args))))
+\f
 (define (pattern->predicate pattern caller)
   (cond ((or (pair? pattern) (null? pattern))
         (list-predicate pattern caller))
@@ -89,7 +108,7 @@ USA.
         pattern)
        (else
         (error:not-a pattern? pattern caller))))
-\f
+
 (define (list-predicate pattern caller)
   (let ((preds (parse-list-pattern pattern caller)))
     (lambda (object)
@@ -116,43 +135,56 @@ USA.
             (predicate (cdr object)))
        (null? object)))
   predicate)
-
-(define (pattern-calling-convention pattern caller)
+\f
+(define (pattern-calling-convention pattern extra-args caller)
   (cond ((pair? pattern)
         (if (pattern-constant? (car pattern))
-            (values (lambda (procedure)
-                      (lambda (object)
-                        (apply procedure (cdr object))))
-                    (pattern-arity (cdr pattern)))
-            (values (lambda (procedure)
-                      (lambda (object)
-                        (apply procedure object)))
-                    (pattern-arity pattern))))
+            (values (pair-wrapper extra-args cdr)
+                    (pattern-arity (cdr pattern) extra-args))
+            (values (pair-wrapper extra-args (lambda (x) x))
+                    (pattern-arity pattern extra-args))))
        ((pattern-constant? pattern)
-        (values (lambda (procedure)
-                  (lambda (object)
-                    (declare (ignore object))
-                    (procedure)))
-                (make-procedure-arity 0)))
-       ((unary-procedure? pattern)
-        (values (lambda (procedure)
-                  procedure)
-                (make-procedure-arity 1)))
+        (values (constant-wrapper extra-args)
+                (make-procedure-arity extra-args)))
+       ((procedure-of-arity? (+ 1 extra-args) pattern)
+        (values (lambda (procedure) procedure)
+                (make-procedure-arity (+ 1 extra-args))))
        (else
         (error:not-a pattern? pattern caller))))
 
-(define (pattern-arity pattern)
-  (let loop ((pattern pattern) (n 0))
-    (cond ((pair? pattern) (loop (cdr pattern) (+ n 1)))
-         ((null? pattern) (make-procedure-arity n))
-         (else (make-procedure-arity n #f)))))
+(define (pair-wrapper extra-args proc)
+  (case extra-args
+    ((0)
+     (lambda (procedure)
+       (lambda (object) (apply procedure (proc object)))))
+    ((1)
+     (lambda (procedure)
+       (lambda (arg object) (apply procedure arg (proc object)))))
+    (else
+     (error "Unsupported extra-args:" extra-args))))
+
+(define (constant-wrapper extra-args)
+  (case extra-args
+    ((0)
+     (lambda (procedure)
+       (lambda (object) (declare (ignore object)) (procedure))))
+    ((1)
+     (lambda (procedure)
+       (lambda (arg object) (declare (ignore object)) (procedure arg))))
+    (else
+     (error "Unsupported extra-args:" extra-args))))
+
+(define (pattern-arity pattern n)
+  (cond ((pair? pattern) (pattern-arity (cdr pattern) (+ n 1)))
+       ((null? pattern) (make-procedure-arity n))
+       (else (make-procedure-arity n #f))))
 \f
 (define-record-type <rules>
-    (%make-rules name adder matcher getter)
+    (%make-rules name extra-args adder getter)
     rules?
   (name rules-name)
+  (extra-args rules-extra-args)
   (adder rules-adder)
-  (matcher rules-matcher)
   (getter rules-getter))
 
 (define-print-method rules?
@@ -167,8 +199,9 @@ USA.
           (iota (length elts))
           elts))))
 
-(define (make-rules name)
-  (let ((rules '()))
+(define (make-rules name #!optional extra-args)
+  (let ((extra-args (if (default-object? extra-args) 0 extra-args))
+       (rules '()))
 
     (define (add! rule)
       (set! rules
@@ -177,39 +210,66 @@ USA.
                             (equal? (rule-key rule)
                                     (rule-key rule*)))
                           rules)))
-      unspecific)
-
-    (define (match object)
-      (let ((matched
-            (filter (lambda (rule)
-                      ((rule-predicate rule) object))
-                    rules)))
-       (and (pair? matched)
-            (begin
-              (if (pair? (cdr matched))
-                  (error "Multiple rule matches:" matched object))
-              (car matched)))))
-
-    (define (get)
-      (list-copy rules))
-
-    (%make-rules name add! match get)))
-
-(define (rules-rewriter rules)
-  (let ((match (rules-matcher rules)))
-    (define (rewrite object)
-      (let ((rule (match object)))
-       (if rule
-           (rewrite ((rule-operation rule) object))
-           object)))
-    rewrite))
+      rule)
 
+    (%make-rules name extra-args add! (lambda () rules))))
+\f
 (define (rules-definer rules)
-  (let ((adder (rules-adder rules)))
+  (let ((adder (rules-adder rules))
+       (extra-args (rules-extra-args rules)))
     (lambda (pattern operation #!optional predicate)
       (adder
        (if (pattern? pattern)
-          (pattern-rule pattern operation predicate)
+          (pattern-rule extra-args pattern operation predicate)
           (general-rule pattern predicate operation))))))
 
+(define (rules-matcher rules)
+  (let ((match
+        (let ((getter (rules-getter rules)))
+          (lambda (predicate)
+            (let ((matched (filter predicate (getter))))
+              (and (pair? matched)
+                   (begin
+                     (if (pair? (cdr matched))
+                         (error "Multiple rule matches:" matched))
+                     (car matched))))))))
+    (case (rules-extra-args rules)
+      ((0)
+       (lambda (object)
+        (match (lambda (rule) ((rule-predicate rule) object)))))
+      ((1)
+       (lambda (arg object)
+        (match (lambda (rule) ((rule-predicate rule) arg object)))))
+      (else
+       (error "Unsupported extra-args:" (rules-extra-args rules))))))
+
+(define (rules-rewriter rules #!optional k)
+  (let ((matcher (rules-matcher rules)))
+    (case (rules-extra-args rules)
+      ((0)
+       (letrec
+          ((rewrite
+            (let ((k (if (default-object? k) (lambda (object) object) k)))
+              (lambda (object)
+                (let ((rule (matcher object)))
+                  (if rule
+                      (rewrite ((rule-operation rule) object))
+                      (k object)))))))
+        rewrite))
+      ((1)
+       (letrec
+          ((rewrite
+            (let ((k
+                   (if (default-object? k)
+                       (lambda (arg object) (declare (ignore arg)) object)
+                       k)))
+              (lambda (arg object)
+                (let ((rule (matcher arg object)))
+                  (if rule
+                      (rewrite arg ((rule-operation rule) arg object))
+                      (k arg object)))))))
+        rewrite))
+      (else
+       (error "Unsupported extra-args:" (rules-extra-args rules))))))
+
 (add-boot-init! (lambda () (run-deferred-boot-actions 'regexp-rules)))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index ce624348ec13f233eda4bc1e1badb190cfa73e08..ad04d333e199c67f7a216e86610395a7933dfa88 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5554,8 +5554,6 @@ USA.
   (parent (runtime))
   (export (runtime regexp)
          make-rules
-         general-rule
-         pattern-rule
          pattern?
          rule-key
          rule-operation

diff --git a/src/runtime/srfi-115.scm b/src/runtime/srfi-115.scm
index bf40615ab6280e833ff96c409e8fde4b2ec2ac5b..c51fff0eecd5b2188e71138a3ba4d050d790694d 100644 (file)
--- a/src/runtime/srfi-115.scm
+++ b/src/runtime/srfi-115.scm
@@ -179,46 +179,31 @@ USA.
     (set! cset-sre-rewrite-rules (make-rules 'cset-sre-rewrite))
     unspecific))
 
-(define (rule-finder rules rewrite-rules)
-  (let ((matcher (rules-matcher rules))
-       (rewriter (rules-rewriter rewrite-rules)))
-    (lambda (object)
-      (matcher (rewriter object)))))
-
 (define-deferred-procedure find-sre-rule 'regexp-rules
-  (rule-finder sre-rules sre-rewrite-rules))
+  (rules-rewriter sre-rewrite-rules (rules-matcher sre-rules)))
 
 (define-deferred-procedure find-cset-sre-rule 'regexp-rules
-  (rule-finder cset-sre-rules cset-sre-rewrite-rules))
-
-(define (pattern-rule-definer rules)
-  (let ((adder (rules-adder rules)))
-    (lambda (pattern operation #!optional predicate)
-      (adder
-       (if (pattern? pattern)
-          (pattern-rule pattern operation predicate)
-          (general-rule pattern predicate operation))))))
+  (rules-rewriter cset-sre-rewrite-rules (rules-matcher cset-sre-rules)))
 
 (define-deferred-procedure define-sre-rule 'regexp-rules
-  (pattern-rule-definer sre-rules))
+  (rules-definer sre-rules))
 
 (define-deferred-procedure define-sre-rewriter 'regexp-rules
-  (pattern-rule-definer sre-rewrite-rules))
+  (rules-definer sre-rewrite-rules))
 
 (define-deferred-procedure define-cset-sre-rule 'regexp-rules
-  (pattern-rule-definer cset-sre-rules))
+  (rules-definer cset-sre-rules))
 
 (define-deferred-procedure define-cset-sre-rewriter 'regexp-rules
-  (pattern-rule-definer cset-sre-rewrite-rules))
+  (rules-definer cset-sre-rewrite-rules))
 
 (define (alias-rule-definer rules)
-  (let ((adder (rules-adder rules)))
+  (let ((definer (rules-definer rules)))
     (lambda (from to)
       (guarantee interned-symbol? from)
       (guarantee interned-symbol? to)
-      (adder
-       (pattern-rule `(,from . ,any-object?)
-                    (lambda args (cons to args)))))))
+      (definer `(,from . ,any-object?)
+       (lambda args (cons to args))))))
 
 (define-deferred-procedure define-sre-alias 'regexp-rules
   (alias-rule-definer sre-rewrite-rules))