From 481ac4be1c2835f161f65926b246d20d604643d5 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Apr 1991 03:11:56 +0000
Subject: [PATCH] Implement new procedures PRESERVING-MATCH-DATA and
 RE-SUBSTITUTE-REGISTERS.  Reimplement REPLACE-MATCH to have same
 functionality as that procedure in GNU Emacs.

---
 v7/src/edwin/edwin.pkg  |   4 +-
 v7/src/edwin/regexp.scm | 100 +++++++++++++++++++++++++++++++---------
 2 files changed, 82 insertions(+), 22 deletions(-)

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index a015a2695..4c9a809a1 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.32 1991/04/24 07:27:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.33 1991/04/26 03:11:56 cph Exp $
 
 Copyright (c) 1989-91 Massachusetts Institute of Technology
 
@@ -494,6 +494,7 @@ MIT in each case. |#
   (parent (edwin))
   (export (edwin)
 	  delete-match
+	  preserving-match-data
 	  re-match-buffer-forward
 	  re-match-end
 	  re-match-end-index
@@ -510,6 +511,7 @@ MIT in each case. |#
 	  re-search-string-forward
 	  re-search-substring-backward
 	  re-search-substring-forward
+	  re-substitute-registers
 	  replace-match
 	  search-backward
 	  search-forward))
diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm
index 1df53577b..369cd2b27 100644
--- a/v7/src/edwin/regexp.scm
+++ b/v7/src/edwin/regexp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.51 1991/04/23 06:47:00 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.52 1991/04/26 03:11:40 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
 ;;;
@@ -47,7 +47,7 @@
 (declare (usual-integrations))
 
 (define registers (make-vector 20))
-(define match-group)
+(define match-group (object-hash false))
 (define standard-syntax-table (make-syntax-table))
 
 (define-integrable (re-match-start-index i)
@@ -58,38 +58,96 @@
 
 (define (re-match-start i)
   (guarantee-re-register i 'RE-MATCH-START)
-  (let ((group (object-unhash match-group)))
-    (if (not group)
-	(error "No match registers" i))
-    (make-mark group (re-match-start-index i))))
+  (let ((index (re-match-start-index i)))
+    (and (not (negative? index))
+	 (make-mark (re-match-group) index))))
 
 (define (re-match-end i)
   (guarantee-re-register i 'RE-MATCH-END)
-  (let ((group (object-unhash match-group)))
-    (if (not group)
-	(error "No match registers" i))
-    (make-mark group (re-match-end-index i))))
+  (let ((index (re-match-end-index i)))
+    (and (not (negative? index))
+	 (make-mark (re-match-group) index))))
 
 (define (guarantee-re-register i operator)
   (if (not (and (exact-nonnegative-integer? i) (< i 10)))
       (error:wrong-type-argument i "RE register" operator)))
 
-(define (replace-match replacement)
-  (let ((m (mark-left-inserting-copy (re-match-start 0))))
-    (delete-string m (re-match-end 0))
-    (insert-string replacement m)
-    (mark-temporary! m)
-    m))
+(define (re-match-group)
+  (let ((group (object-unhash match-group)))
+    (if (not group)
+	(error "No match group"))
+    group))
 
-(define (delete-match)
-  (let ((m (mark-left-inserting-copy (re-match-start 0))))
-    (delete-string m (re-match-end 0))
-    (mark-temporary! m)
-    m))
+(define (preserving-match-data thunk)
+  (fluid-let ((registers (vector-copy registers))
+	      (match-group match-group))
+    (thunk)))
 
 (define-integrable (syntax-table-argument syntax-table)
   (syntax-table/entries (or syntax-table standard-syntax-table)))
 
+(define (replace-match replacement #!optional preserve-case? literal?)
+  (let ((start (re-match-start 0))
+	(end (re-match-end 0)))
+    (let ((replacement
+	   (let ((replacement
+		  (if (and (not (default-object? literal?)) literal?)
+		      replacement
+		      (re-substitute-registers replacement))))
+	     (if (and (not (default-object? preserve-case?) preserve-case?))
+		 ;; Emacs uses a more complicated algorithm here,
+		 ;; which breaks the replaced string into words,
+		 ;; makes the decision based on examining all the
+		 ;; words, and then changes each word in the
+		 ;; replacement to match the pattern.
+		 (let ((replaced (extract-string start end)))
+		   (cond ((string-upper-case? replaced)
+			  (string-upcase replacement))
+			 ((string-capitalized? replaced)
+			  (string-capitalize replacement))
+			 (else replacement)))
+		 replacement))))
+      (delete-string start end)
+      (insert-string replacement start))
+    start))
+
+(define (re-substitute-registers string)
+  (let ((end (string-length string)))
+    (if (substring-find-next-char string 0 end #\\)
+	(apply
+	 string-append
+	 (let loop ((start 0))
+	   (let ((slash (substring-find-next-char string start end #\\)))
+	     (if slash
+		 (cons (substring string start slash)
+		       (let ((next (+ slash 1)))
+			 (cons (let ((char
+				      (if (< next end)
+					  (string-ref string next)
+					  #\\)))
+				 (let ((n
+					(if (char=? #\& char)
+					    0
+					    (char->digit char))))
+				   (cond ((not n)
+					  (string char))
+					 ((negative? (re-match-start-index n))
+					  (string #\\ char))
+					 (else
+					  (extract-string
+					   (re-match-start n)
+					   (re-match-end n))))))
+			       (if (< next end)
+				   (loop (+ next 1))
+				   '()))))
+		 (list (substring string start end))))))
+	string)))
+
+(define (delete-match)
+  (let ((start (re-match-start 0)))
+    (delete-string start (re-match-end 0))
+    start))
+
 (define (re-search-buffer-forward pattern case-fold-search syntax-table
 				  group start end)
   (let ((index
-- 
2.25.1