added finalizer for cre

scsh/rx/re-low.scm

@@ -44,13 +44,31 @@
 ;;; We compile the string two ways, on demand -- one for cre-search, and
 ;;; one for cre-search?.
 
-(define-record cre	; A compiled regular expression
+;(define-record cre	; A compiled regular expression
-  string		; The Posix string form of the regexp or #F.
+;  string		; The Posix string form of the regexp or #F.
-  max-paren		; Max paren in STRING needed for submatches.
+;  max-paren		; Max paren in STRING needed for submatches.
-  (bytes    #f)		; Pointer to the compiled form, in the C heap, or #F.
+;  (bytes    #f)		; Pointer to the compiled form, in the C heap, or #F.
-  (bytes/nm #f)		; Same as BYTES, but compiled with no-submatch.
+;  (bytes/nm #f)		; Same as BYTES, but compiled with no-submatch.
-  tvec			; Translation vector for the submatches
+;  tvec			; Translation vector for the submatches
-  ((disclose self) (list "cre" (cre:string self))))
+;  ((disclose self) (list "cre" (cre:string self))))
+
+(define-record-type cre :cre
+  (really-make-cre string max-paren bytes bytes/nm tvec debug)
+  cre?
+  (string cre:string set-cre:string)
+  (max-paren cre:max-paren set-cre:max-paren)
+  (bytes cre:bytes set-cre:bytes)
+  (bytes/nm cre:bytes/nm set-cre:bytes/nm)
+  (tvec cre:tvec set-cre:tvec)
+  (debug cre:debug set-cre:debug))
+
+(define-record-discloser :cre
+        (lambda (self) (list "cre" (cre:string self))))
+
+
+(define (make-cre str max-paren tvec)
+  (really-make-cre str max-paren #f #f tvec #f))
+
 
 (define (new-cre str tvec) (make-cre str (max-live-posix-submatch tvec) tvec))
 
@@ -78,7 +96,7 @@
 	 (let* ((C-bytes (or (cre:bytes cre)
 			     (let ((C-bytes (compile-posix-re->c-struct re-str #t)))
 			       (set-cre:bytes cre C-bytes)
-			       (register-re-c-struct cre C-bytes)
+			       (register-re-c-struct:bytes cre)
 			       C-bytes)))
 		(retcode (%cre-search C-bytes str start
 				      (cre:tvec cre)
@@ -95,7 +113,7 @@
 	 (let* ((C-bytes (or (cre:bytes/nm cre)
 			     (let ((C-bytes (compile-posix-re->c-struct re-str #f)))
 			       (set-cre:bytes/nm cre C-bytes)
-			       (register-re-c-struct cre C-bytes)
+			       (register-re-c-struct:bytes/nm cre)
 			       C-bytes)))
 		(retcode (%cre-search C-bytes str start '#() -1 '#() '#())))
 	   (if (integer? retcode)
@@ -121,34 +139,31 @@
 
 ;;; Reclaiming compiled regexp storage
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Avert your eyes from the unsightly crock.
-;;;
-;;; S48 0.36 doesn't have finalizers, so we don't have a way to free
-;;; the C regexp_t structure when its CRE record is gc'd. So our current
-;;; lame approximation is to keep track of all the CRE's with a list of
-;;;     (cre-weak-pointer . regex_t*)
-;;; pairs. From time to time, we should walk the list. If we deref the
-;;; weak pointer and discover the CRE's been GC'd, we free the regex_t
-;;; struct.
-;;;
-;;; Note this code is completely thread unsafe.
-
-;;; Free the space used by a compiled regexp.
 (define-foreign %free-re (free_re ((C regex_t*) re)) ignore)
 
-(define *master-cre-list* '())
 
-;;; Whenever we make a new CRE, use this proc to add it to the master list.
+;;; Whenever we make a new CRE, add the appropriate finalizer, 
+;;; so the C regex_t structure can be freeed
+
+(define (free-bytes the-cre)
+  (if (cre:bytes the-cre)
+      (%free-re (cre:bytes the-cre))
+      (error "free-bytes called on #f")))
+  
+(define (free-bytes/nm the-cre)
+    (if (cre:bytes the-cre)
+	(%free-re (cre:bytes/nm the-cre))
+	(error "free-bytes called on #f")))
+
+(define  (register-re-c-struct:bytes cre)
+  (add-finalizer! cre free-bytes))
+
+(define  (register-re-c-struct:bytes/nm cre)
+  (add-finalizer! cre free-bytes/nm))
+
+
 (define (register-re-c-struct cre c-bytes)
-  (set! *master-cre-list* (cons (cons (make-weak-pointer cre) c-bytes)
+  (error "function register-re-c-struct no longer supported"))
-				*master-cre-list*)))
 
 (define (clean-up-cres)
-  (set! *master-cre-list*
+  (warn "function clean-up-cres no longer supported"))
-	(fold (lambda (elt lis)
-		(if (weak-pointer-ref (car elt)) ; Still alive
-		    (cons elt lis)
-		    (begin (%free-re (cdr elt))
-			   lis)))
-	      '()
-	      *master-cre-list*)))