From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 3 May 2017 06:00:27 +0000 (-0700)
Subject: Change groups abstraction to use message-passing style.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~93
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=74409d6d2a04ea758ce3e07b14e5d564795859fe;p=mit-scheme.git

Change groups abstraction to use message-passing style.
---

diff --git a/src/runtime/regsexp.scm b/src/runtime/regsexp.scm
index fde418ded..a33cbdfb4 100644
--- a/src/runtime/regsexp.scm
+++ b/src/runtime/regsexp.scm
@@ -74,7 +74,8 @@ USA.
 
 (define (top-level-match crsexp start-position)
   (let ((result
-	 ((compiled-regsexp-impl crsexp) start-position '() (lambda () #f))))
+	 ((compiled-regsexp-impl crsexp)
+	  start-position (make-groups) (lambda () #f))))
     (and result
 	 (cons (%make-range (get-index start-position)
 			    (car result))
@@ -476,112 +477,40 @@ USA.
 (define (next-char position)
   ((position 'next-char)))
 
+(define (next-position position)
+  ((position 'next-position)))
+
 (define (prev-char position)
   ((position 'prev-char)))
 
-(define (next-position position)
-  ((position 'next-position)))
+(define (prev-position position)
+  ((position 'prev-position)))
 
 (define (same-positions? p1 p2)
   (and (eq? ((p1 'get-marker)) ((p2 'get-marker)))
        (fix:= ((p1 'get-index)) ((p2 'get-index)))))
 
-;;;; Groups
-
-(define (%start-group key position groups)
-  (cons (list key position)
-	groups))
-
-(define (%end-group key position groups)
-  ;; Kind of slow, but it's functional.  Could speed up with side
-  ;; effects.
-  (let ((p (assq key groups)))
-    (if (not (and p (null? (cddr p))))
-	(error "%END-GROUP called with no %START-GROUP:" key))
-    (cons (list key (cadr p) position)
-	  (delq p groups))))
-
-(define (%find-group key groups)
-  (let ((p (assq key groups)))
-    (if (not p)
-	;; This can happen with (* (GROUP ...)), but in other cases it
-	;; would be an error.
-	(insn:always-succeed)
-	(begin
-	  (if (null? (cddr p))
-	      (error "Reference to group appears before group's end:" key))
-	  (insn:chars (%group-chars (cadr p) (caddr p)))))))
-
-(define (%group-chars start-position end-position)
-  (let loop ((position start-position) (chars '()))
-    (if (same-positions? position end-position)
-	(reverse! chars)
-	(let ((char (next-char position)))
-	  (if (not char)
-	      (error "Failure of SAME? predicate"))
-	  (loop (next-position position)
-		(cons char chars))))))
-
-(define (%convert-groups groups)
-  (map (lambda (g)
-	 (cons (car g)
-	       (%make-range (get-index (cadr g))
-			    (get-index (caddr g)))))
-       (remove (lambda (g)
-		 (null? (cddr g)))
-	       groups)))
-
-(define-integrable (%make-range start end)
-  (cons start end))
-
-;;;; Match input port
-
-(define (regsexp-match-input-port crsexp port)
-  (top-level-match crsexp
-		   (make-source-position
-		    (lambda ()
-		      (let ((char (read-char port)))
-			(if (eof-object? char)
-			    #f
-			    char))))))
-
 (define (make-source-position source)
   (let ((marker (list 'source-position)))
 
-    (define (at-index index next-char prev-char)
+    (define (at-index index next-char prev-char prev-position)
 
       (define (next-position)
-	(at-index (fix:+ index 1) (source) next-char))
+	(at-index (fix:+ index 1) (source) next-char this))
 
-      (lambda (operator)
+      (define (this operator)
 	(case operator
 	  ((get-marker) (lambda () marker))
 	  ((get-index) (lambda () index))
 	  ((next-char) (lambda () next-char))
-	  ((prev-char) (lambda () prev-char))
 	  ((next-position) next-position)
-	  (else (error "Unknown operator:" operator)))))
-
-    (at-index 0 (source) #f)))
-
-;;;; Match string
+	  ((prev-char) (lambda () prev-char))
+	  ((prev-position) (lambda () prev-position))
+	  (else (error "Unknown operator:" operator))))
 
-(define (regsexp-match-string crsexp string #!optional start end)
-  (let* ((caller 'regsexp-match-string)
-	 (end (fix:end-index end (string-length string) caller))
-	 (start (fix:start-index start end caller)))
-    (guarantee nfc-string? string caller)
-    (top-level-match crsexp (make-string-position string start end))))
+      this)
 
-(define (regsexp-search-string-forward crsexp string #!optional start end)
-  (let* ((caller 'regsexp-search-string-forward)
-	 (end (fix:end-index end (string-length string) caller))
-	 (start (fix:start-index start end caller)))
-    (guarantee nfc-string? string caller)
-    (let loop ((position (make-string-position string start end)))
-      (or (top-level-match crsexp position)
-	  (and (next-char position)
-	       (loop (next-position position)))))))
+    (at-index 0 (source) #f #f)))
 
 (define (make-string-position string start end)
   (let ((marker (list 'string-position)))
@@ -592,24 +521,126 @@ USA.
 	(and (fix:< index end)
 	     (string-ref string index)))
 
+      (define (next-position)
+	(at-index (fix:+ index 1)))
+
       (define (prev-char)
 	(and (fix:> index start)
 	     (string-ref string (fix:- index 1))))
 
-      (define (next-position)
-	(at-index (fix:+ index 1)))
+      (define (prev-position)
+	(at-index (fix:- index 1)))
 
       (lambda (operator)
 	(case operator
 	  ((get-marker) (lambda () marker))
 	  ((get-index) (lambda () index))
 	  ((next-char) next-char)
-	  ((prev-char) prev-char)
 	  ((next-position) next-position)
+	  ((prev-char) prev-char)
+	  ((prev-position) prev-position)
 	  (else (error "Unknown operator:" operator)))))
 
     (at-index start)))
 
+;;;; Groups
+
+(define (make-groups)
+
+  (define (loop groups)
+
+    (define (start key position)
+      (loop (cons (list key position) groups)))
+
+    (define (end key position)
+      ;; Kind of slow, but it's functional.  Could speed up with side effects.
+      (let ((p (assq key groups)))
+	(if (not (and p (null? (cddr p))))
+	    (error "%END-GROUP called with no %START-GROUP:" key))
+	(loop (cons (list key (cadr p) position)
+		    (delq p groups)))))
+
+    (define (find key)
+      (let ((p (assq key groups)))
+	(if (not p)
+	    ;; This can happen with (* (GROUP ...)), but in other cases it
+	    ;; would be an error.
+	    (insn:always-succeed)
+	    (begin
+	      (if (null? (cddr p))
+		  (error "Reference to group appears before group's end:" key))
+	      (insn:chars (%group-chars (cadr p) (caddr p)))))))
+
+    (define (%group-chars start-position end-position)
+      (let loop ((position end-position) (chars '()))
+	(if (same-positions? position start-position)
+	    chars
+	    (let ((char (prev-char position)))
+	      (loop (prev-position position)
+		    (cons char chars))))))
+
+    (define (convert)
+      (map (lambda (g)
+	     (cons (car g)
+		   (%make-range (get-index (cadr g))
+				(get-index (caddr g)))))
+	   (remove (lambda (g)
+		     (null? (cddr g)))
+		   groups)))
+
+    (lambda (operator)
+      (case operator
+	((start) start)
+	((end) end)
+	((find) find)
+	((convert) convert)
+	(else (error "Unknown operator:" operator)))))
+
+  (loop '()))
+
+(define (%start-group key position groups)
+  ((groups 'start) key position))
+
+(define (%end-group key position groups)
+  ((groups 'end) key position))
+
+(define (%find-group key groups)
+  ((groups 'find) key))
+
+(define (%convert-groups groups)
+  ((groups 'convert)))
+
+(define-integrable (%make-range start end)
+  (cons start end))
+
+;;;; Match and search
+
+(define (regsexp-match-string crsexp string #!optional start end)
+  (let* ((caller 'regsexp-match-string)
+	 (end (fix:end-index end (string-length string) caller))
+	 (start (fix:start-index start end caller)))
+    (guarantee nfc-string? string caller)
+    (top-level-match crsexp (make-string-position string start end))))
+
+(define (regsexp-search-string-forward crsexp string #!optional start end)
+  (let* ((caller 'regsexp-search-string-forward)
+	 (end (fix:end-index end (string-length string) caller))
+	 (start (fix:start-index start end caller)))
+    (guarantee nfc-string? string caller)
+    (let loop ((position (make-string-position string start end)))
+      (or (top-level-match crsexp position)
+	  (and (next-char position)
+	       (loop (next-position position)))))))
+
+(define (regsexp-match-input-port crsexp port)
+  (top-level-match crsexp
+		   (make-source-position
+		    (lambda ()
+		      (let ((char (read-char port)))
+			(if (eof-object? char)
+			    #f
+			    char))))))
+
 ;;;; Convert regexp pattern to regsexp
 
 (define (re-pattern->regsexp pattern)