From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 22 Jun 1999 18:07:19 +0000 (+0000)
Subject: Change external representation of regular-expression registers so that
X-Git-Tag: 20090517-FFI~4517
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c59c306372aeddfa1acbf57fd791082a4abe823b;p=mit-scheme.git

Change external representation of regular-expression registers so that
predicate is uniquely true of these objects.  Modify
re-match-start-index and re-match-end-index to accept one of these
objects as an optional argument, meaning to reference the object
rather than the internal registers.
---

diff --git a/v7/src/runtime/regexp.scm b/v7/src/runtime/regexp.scm
index 35df4d185..15a4027ba 100644
--- a/v7/src/runtime/regexp.scm
+++ b/v7/src/runtime/regexp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: regexp.scm,v 1.2 1999/06/21 20:58:56 cph Exp $
+;;; $Id: regexp.scm,v 1.3 1999/06/22 18:07:19 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -29,40 +29,41 @@
   (set! registers (make-vector 20 #f))
   unspecific)
 
-(define (re-match-start-index i)
+(define-structure (re-registers (type-descriptor re-registers-rtd))
+  (vector #f read-only #t))
+
+(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 (re-match-start-index i #!optional regs)
   (guarantee-re-register i 'RE-MATCH-START-INDEX)
-  (vector-ref registers i))
+  (vector-ref (if (or (default-object? regs) (not regs))
+		  registers
+		  (guarantee-re-registers regs 'RE-MATCH-START-INDEX))
+	      i))
 
-(define (re-match-end-index i)
+(define (re-match-end-index i #!optional regs)
   (guarantee-re-register i 'RE-MATCH-END-INDEX)
-  (vector-ref registers (fix:+ i 10)))
+  (vector-ref (if (or (default-object? regs) (not regs))
+		  registers
+		  (guarantee-re-registers regs 'RE-MATCH-START-INDEX))
+	      (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)
-  (vector-copy registers))
+  (make-re-registers (vector-copy registers)))
 
-(define (set-re-registers! registers*)
-  (guarantee-re-registers registers* 'SET-RE-REGISTERS!)
-  (do ((i 0 (fix:+ i 1)))
-      ((fix:= 20 i))
-    (vector-set! registers i (vector-ref registers* i))))
-
-(define (guarantee-re-registers object procedure)
-  (if (not (re-registers? object))
-      (error:wrong-type-argument object "regular-expression registers"
-				 procedure)))
-
-(define (re-registers? object)
-  (and (vector? object)
-       (fix:= 20 (vector-length object))
-       (let loop ((i 0))
-	 (or (fix:= 20 i)
-	     (and (or (index-fixnum? (vector-ref object i))
-		      (not (vector-ref object i)))
-		  (loop (fix:+ i 1)))))))
+(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))