From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 30 Nov 2019 01:19:48 +0000 (-0800)
Subject: Implement char-set-size and update char-set:newline.
X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~43
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4cf364ed349780138db9738bc5f0df71eda41ccb;p=mit-scheme.git

Implement char-set-size and update char-set:newline.
---

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index a91e03170..efba94f88 100644
--- a/src/runtime/char-set.scm
+++ b/src/runtime/char-set.scm
@@ -224,6 +224,39 @@ USA.
 
 (define-integrable (rcons start end ilist)
   (cons end (cons start ilist)))
+
+(define (char-set-size char-set)
+  (fix:+ (%low-size (%char-set-low char-set))
+	 (%high-size (%char-set-high char-set))))
+
+(define (%low-size low)
+  (let ((low-limit (%low-limit low)))
+
+    (define (find-start i size)
+      (if (fix:< i low-limit)
+	  (if (%low-ref low i)
+	      (let ((end (find-end (fix:+ i 1))))
+		(find-start end (fix:+ size (fix:- end i))))
+	      (find-start (fix:+ i 1) size))
+	  size))
+
+    (define (find-end i)
+      (if (fix:< i low-limit)
+	  (if (%low-ref low i)
+	      (find-end (fix:+ i 1))
+	      i)
+	  low-limit))
+
+    (find-start 0 0)))
+
+(define (%high-size high)
+  (let ((end (%high-length high)))
+    (do ((index 0 (fix:+ index 2))
+	 (size 0
+		(fix:+ size
+		       (fix:- (%high-ref high (fix:+ index 1))
+			      (%high-ref high index)))))
+	((not (fix:< index end)) size))))
 
 (define (make-inversion-list-combiner combine)
 
@@ -378,6 +411,7 @@ USA.
     ((graphic graph) char-set:graphic)
     ((hex-digit xdigit) char-set:hex-digit)
     ((lower-case lower) char-set:lower-case)
+    ((newline nl) char-set:newline)
     ((no-newline nonl) char-set:no-newline)
     ((numeric num) char-set:numeric)
     ((printing print) char-set:printing)
@@ -587,13 +621,10 @@ USA.
 (define char-set:ascii)
 (define char-set:ctls)
 (define char-set:hex-digit)
-(define char-set:newline)
 (define char-set:wsp)
 (define char-wsp?)
 (add-boot-init!
  (lambda ()
-
-   (set! char-set:newline (char-set #\newline))
    (set! char-set:hex-digit (char-set "0123456789abcdefABCDEF"))
 
    ;; Used in RFCs:
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f3336c19d..3fd354e6f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1571,10 +1571,12 @@ USA.
   (export ()
 	  char-alphanumeric?
 	  char-graphic?
+	  char-newline?
 	  char-printing?
 	  char-set:alphanumeric
 	  char-set:control
 	  char-set:graphic
+	  char-set:newline
 	  char-set:no-newline
 	  char-set:not-alphabetic
 	  char-set:not-alphanumeric
@@ -1624,12 +1626,12 @@ USA.
 	  char-set-invert
 	  char-set-members
 	  char-set-predicate
+	  char-set-size
 	  char-set-union
 	  char-set-union*
 	  char-set:ascii
 	  char-set:ctls
 	  char-set:hex-digit
-	  char-set:newline
 	  char-set:wsp
 	  char-set=?
 	  char-set?
diff --git a/src/runtime/ucd-glue.scm b/src/runtime/ucd-glue.scm
index d9e591479..940054b04 100644
--- a/src/runtime/ucd-glue.scm
+++ b/src/runtime/ucd-glue.scm
@@ -90,8 +90,10 @@ USA.
 (define-deferred char-set:not-graphic (char-set-invert char-set:graphic))
 (define-deferred char-graphic? (char-set-predicate char-set:graphic))
 
+(define-deferred char-set:newline (char-set #\newline #\return))
 (define-deferred char-set:no-newline
-  (char-set-difference char-set:unicode (char-set #\newline #\return)))
+  (char-set-difference char-set:unicode char-set:newline))
+(define-deferred char-newline? (char-set-predicate char-set:newline))
 
 (define-deferred char-set:printing
   (char-set-union char-set:graphic