From 77cf9daf19b24836ca6bcc263aaca2611c40a901 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 29 Apr 2017 23:44:37 -0700
Subject: [PATCH] Minor cleanups to regexp code.

---
 src/runtime/optiondb.scm | 16 +++++-----
 src/runtime/regexp.scm   | 67 +++++++++++++++++++---------------------
 src/runtime/runtime.pkg  |  2 --
 3 files changed, 39 insertions(+), 46 deletions(-)

diff --git a/src/runtime/optiondb.scm b/src/runtime/optiondb.scm
index 84b93321b..963e5b399 100644
--- a/src/runtime/optiondb.scm
+++ b/src/runtime/optiondb.scm
@@ -78,17 +78,17 @@ USA.
    ))
 
 (define-load-option 'REGULAR-EXPRESSION
-  (standard-option-loader '(RUNTIME REGULAR-EXPRESSION-COMPILER)
-			  #F
+  (standard-option-loader '(runtime regular-expression-compiler)
+			  #f
 			  "rgxcmp")
-  (standard-option-loader '(RUNTIME CHAR-SYNTAX)
-			  '(INITIALIZE-PACKAGE!)
+  (standard-option-loader '(runtime char-syntax)
+			  '(initialize-package!)
 			  "chrsyn")
-  (standard-option-loader '(RUNTIME REGULAR-EXPRESSION)
-			  '(INITIALIZE-PACKAGE!)
+  (standard-option-loader '(runtime regular-expression)
+			  #f
 			  "regexp")
-  (standard-option-loader '(RUNTIME REXP)
-			  #F
+  (standard-option-loader '(runtime rexp)
+			  #f
 			  "rexp"))
 
 ;; HASH-TABLE is now always loaded.
diff --git a/src/runtime/regexp.scm b/src/runtime/regexp.scm
index cd1b4d498..c589ee459 100644
--- a/src/runtime/regexp.scm
+++ b/src/runtime/regexp.scm
@@ -29,63 +29,58 @@ USA.
 
 (declare (usual-integrations))
 
-(define registers)
+(define-deferred registers (make-vector 20 #f))
 
-(define (initialize-package!)
-  (set! registers (make-vector 20 #f))
-  unspecific)
+(define (re-register? object)
+  (and (index-fixnum? object)
+       (fix:< object 10)))
 
-(define-structure (re-registers (type-descriptor <re-registers>))
-  (vector #f read-only #t))
+(define (re-registers)
+  (make-re-registers (vector-copy registers)))
 
-(define (guarantee-re-registers object procedure)
-  (if (not (re-registers? object))
-      (error:wrong-type-argument object "regular-expression registers"
-				 procedure))
-  (re-registers-vector object))
+(define (set-re-registers! regs)
+  (vector-copy! registers 0 (re-registers-vector regs)))
+
+(define-record-type <re-registers>
+    (make-re-registers vector)
+    re-registers?
+  (vector re-registers-vector))
 
 (define (re-match-start-index i #!optional regs)
-  (guarantee-re-register i 'RE-MATCH-START-INDEX)
+  (guarantee re-register? i 're-match-start-index)
   (vector-ref (if (or (default-object? regs) (not regs))
 		  registers
-		  (guarantee-re-registers regs 'RE-MATCH-START-INDEX))
+		  (re-registers-vector regs))
 	      i))
 
 (define (re-match-end-index i #!optional regs)
-  (guarantee-re-register i 'RE-MATCH-END-INDEX)
-  (vector-ref (if (or (default-object? regs) (not regs))
+  (guarantee re-register? i 're-match-end-index)
+  (vector-ref (if (default-object? regs)
 		  registers
-		  (guarantee-re-registers regs 'RE-MATCH-START-INDEX))
+		  (re-registers-vector regs))
 	      (fix:+ i 10)))
 
-(define (guarantee-re-register i operator)
-  (if (not (and (exact-nonnegative-integer? i) (< i 10)))
-      (error:wrong-type-argument i "regular-expression register" operator)))
-
-(define (re-registers)
-  (make-re-registers (vector-copy registers)))
-
-(define (set-re-registers! regs)
-  (let ((regs (guarantee-re-registers regs 'SET-RE-REGISTERS!)))
-    (do ((i 0 (fix:+ i 1)))
-	((fix:= 20 i))
-      (vector-set! registers i (vector-ref regs i)))))
-
-(define (preserving-re-registers thunk)
-  (let ((registers* unspecific))
-    (dynamic-wind (lambda () (set! registers* (re-registers)) unspecific)
-		  thunk
-		  (lambda () (set-re-registers! registers*)))))
-
 (define (re-match-extract string regs i)
   (let ((start (re-match-start-index i regs))
 	(end (re-match-end-index i regs)))
     (if (not (and start end))
-	(error:bad-range-argument i 'RE-MATCH-EXTRACT))
+	(error:bad-range-argument i 're-match-extract))
     (substring string start end)))
+
+(define (preserving-re-registers thunk)
+  (let ((registers* unspecific))
+    (dynamic-wind (lambda ()
+		    (set! registers* (re-registers))
+		    unspecific)
+		  thunk
+		  (lambda ()
+		    (set-re-registers! registers*)
+		    (set! registers*)
+		    unspecific))))
 
 (define (make-substring-operation primitive)
   (lambda (regexp string start end #!optional case-fold? syntax-table)
+    (guarantee 8-bit-string? string)
     (let ((regexp
 	   (if (compiled-regexp? regexp)
 	       regexp
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b44bb16fc..d5f210559 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5254,8 +5254,6 @@ USA.
   (parent (runtime))
   (export ()
 	  char-set->regexp
-	  guarantee-re-register
-	  guarantee-re-registers
 	  preserving-re-registers
 	  re-match-end-index
 	  re-match-extract
-- 
2.25.1