From 91f889eda32660f6182109b15ed906626f07bee7 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 4 Jun 2005 03:42:46 +0000 Subject: [PATCH] Implement N*M, N*N, *N, and N* patterns. --- v7/src/star-parser/load.scm | 6 +- v7/src/star-parser/matcher.scm | 101 ++++++++++++++++++++++++++++++++- 2 files changed, 101 insertions(+), 6 deletions(-) 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 -- 2.25.1