From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 4 Jun 2005 03:42:46 +0000 (+0000)
Subject: Implement N*M, N*N, *N, and N* patterns.
X-Git-Tag: 20090517-FFI~1284
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=91f889eda32660f6182109b15ed906626f07bee7;p=mit-scheme.git

Implement N*M, N*N, *N, and N* patterns.
---

diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm
index 3a5c1115a..4ac820eb6 100644
--- a/v7/src/star-parser/load.scm
+++ b/v7/src/star-parser/load.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 1.17 2004/12/13 03:22:21 cph Exp $
+$Id: load.scm,v 1.18 2005/06/04 03:42:46 cph Exp $
 
-Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -26,4 +26,4 @@ USA.
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     (load-package-set "parser")))
-(add-subsystem-identification! "*Parser" '(0 12))
\ No newline at end of file
+(add-subsystem-identification! "*Parser" '(0 13))
\ No newline at end of file
diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index 07de51b97..7891dc6a4 100644
--- a/v7/src/star-parser/matcher.scm
+++ b/v7/src/star-parser/matcher.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: matcher.scm,v 1.33 2004/02/16 05:46:41 cph Exp $
+$Id: matcher.scm,v 1.34 2005/06/04 03:42:28 cph Exp $
 
-Copyright 2001,2002,2004 Massachusetts Institute of Technology
+Copyright 2001,2002,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -128,6 +128,16 @@ USA.
   (lambda (expression)
     `(SEQ ,expression (DISCARD-MATCHED))))
 
+(define-*matcher-expander 'N*
+  (lambda (n expression)
+    `(SEQ (N*N ,n ,expression)
+	  (* ,expression))))
+
+(define-*matcher-expander 'N*M
+  (lambda (n m expression)
+    `(SEQ (N*N ,n ,expression)
+	  (*N ,(- m n) ,expression))))
+
 (define-matcher-preprocessor '(ALT SEQ)
   (lambda (expression external-bindings internal-bindings)
     `(,(car expression)
@@ -143,6 +153,16 @@ USA.
 				      external-bindings
 				      internal-bindings))))
 
+(define-matcher-preprocessor '(N*N *N)
+  (lambda (expression external-bindings internal-bindings)
+    (check-n-args 2 expression
+      (lambda (expression)
+	(exact-nonnegative-integer? (cadr expression))))
+    `(,(car expression) ,(cadr expression)
+			,(preprocess-matcher-expression (caddr expression)
+							external-bindings
+							internal-bindings))))
+
 (define-matcher-preprocessor '(CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI ALPHABET)
   (lambda (expression external-bindings internal-bindings)
     external-bindings internal-bindings
@@ -360,4 +380,79 @@ USA.
 	       (compile-matcher-expression expression #f ks2 kf free-names))
 	     (backtracking-kf pointer
 	       (lambda ()
-		 (delay-call ks kf2)))))))))
\ No newline at end of file
+		 (delay-call ks kf2)))))))))
+
+(define-matcher (n*n n expression)
+  (if (<= n 4)
+      (open-code-n*n n expression pointer ks kf free-names)
+      (close-code-n*n n expression pointer ks kf free-names)))
+
+(define (open-code-n*n n expression pointer ks kf free-names)
+  (let loop ((n n) (pointer pointer) (kf kf))
+    (if (> n 0)
+	(bind-delayed-lambdas
+	 (lambda (ks)
+	   (compile-matcher-expression expression pointer ks kf
+				       free-names))
+	 (make-matcher-ks-lambda
+	  (lambda (kf)
+	    (loop (- n 1) #f kf))))
+	(delay-call ks kf))))
+
+(define (close-code-n*n n expression pointer ks kf free-names)
+  ;; Assume (>= N 1).
+  pointer
+  (let ((l1 (make-loop-identifier))
+	(n1 (make-value-identifier))
+	(kf2 (make-kf-identifier)))
+    `(LET ,l1 ((,n1 ,n) (,kf2 ,(delay-reference kf)))
+       (IF (> ,n1 1)
+	   ,(bind-delayed-lambdas
+	     (lambda (ks)
+	       (compile-matcher-expression expression #f ks kf2 free-names))
+	     (make-matcher-ks-lambda
+	      (lambda (kf)
+		`(,l1 (- ,n1 1) ,kf))))
+	   ,(compile-matcher-expression expression #f ks kf2 free-names)))))
+
+(define-matcher (*n n expression)
+  (if (<= n 4)
+      (open-code-*n n expression pointer ks kf free-names)
+      (close-code-*n n expression pointer ks kf free-names)))
+
+(define (open-code-*n n expression pointer ks kf free-names)
+  (bind-delayed-lambdas
+   (lambda (kf)
+     (let loop ((n n) (pointer pointer) (kf kf))
+       (if (> n 0)
+	   (bind-delayed-lambdas
+	    (lambda (ks)
+	      (compile-matcher-expression expression pointer ks kf free-names))
+	    (make-matcher-ks-lambda
+	     (lambda (kf)
+	       (loop (- n 1) #f kf))))
+	   (delay-call ks kf))))
+   (make-kf-lambda
+    (lambda ()
+      (delay-call ks kf)))))
+
+(define (close-code-*n n expression pointer ks kf free-names)
+  ;; Assume (>= N 1).
+  pointer
+  (bind-delayed-lambdas
+   (lambda (kf)
+     (let ((l1 (make-loop-identifier))
+	   (n1 (make-value-identifier))
+	   (kf2 (make-kf-identifier)))
+       `(LET ,l1 ((,n1 ,n) (,kf2 ,(delay-reference kf)))
+	  (IF (> ,n1 1)
+	      ,(bind-delayed-lambdas
+		(lambda (ks)
+		  (compile-matcher-expression expression #f ks kf2 free-names))
+		(make-matcher-ks-lambda
+		 (lambda (kf)
+		   `(,l1 (- ,n1 1) ,kf))))
+	      ,(compile-matcher-expression expression #f ks kf2 free-names)))))
+   (make-kf-lambda
+    (lambda ()
+      (delay-call ks kf)))))
\ No newline at end of file