Char-set refactor: SRFI 14 complete.

diff --git a/src/libraries/srfi-14.scm b/src/libraries/srfi-14.scm
new file mode 100644 (file)
index 0000000..b2c4d17
--- /dev/null
+++ b/src/libraries/srfi-14.scm
@@ -0,0 +1,167 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; SRFI 14: Character-set Library
+
+(define-library (srfi 14)
+  (import (scheme base)
+         (scheme char)
+         (only (srfi 1)
+               drop-right
+               last)
+         (srfi 143)
+         (only (mit legacy runtime)
+               ->char-set
+               char-set->list
+               char-set->string
+               char-set-adjoin
+               char-set-adjoin!
+               char-set-any
+               char-set-complement
+               char-set-complement!
+               char-set-contains?
+               char-set-copy
+               char-set-count
+               char-set-cursor
+               char-set-cursor-next
+               char-set-delete
+               char-set-delete!
+               char-set-diff+intersection
+               char-set-diff+intersection!
+               char-set-difference
+               char-set-difference!
+               char-set-every
+               char-set-filter
+               char-set-filter!
+               char-set-fold
+               char-set-for-each
+               char-set-hash
+               char-set-intersection
+               char-set-intersection!
+               char-set-map
+               char-set-ref
+               char-set-size
+               char-set-unfold
+               char-set-unfold!
+               char-set-union
+               char-set-union!
+               char-set-xor
+               char-set-xor!
+               char-set:ascii
+               char-set:blank
+               char-set:digit
+               char-set:empty
+               char-set:full
+               char-set:graphic
+               char-set:hex-digit
+               char-set:iso-control
+               char-set:letter
+               char-set:letter+digit
+               char-set:lower-case
+               char-set:printing
+               char-set:punctuation
+               char-set:symbol
+               char-set:title-case
+               char-set:upper-case
+               char-set:whitespace
+               char-set<=
+               char-set=
+               char-set?
+               end-of-char-set?
+               list->char-set
+               list->char-set!
+               string->char-set
+               string->char-set!
+               ucs-range->char-set
+               ucs-range->char-set!))
+  (export ->char-set
+         char-set
+         char-set->list
+         char-set->string
+         char-set-adjoin
+         char-set-adjoin!
+         char-set-any
+         char-set-complement
+         char-set-complement!
+         char-set-contains?
+         char-set-copy
+         char-set-count
+         char-set-cursor
+         char-set-cursor-next
+         char-set-delete
+         char-set-delete!
+         char-set-diff+intersection
+         char-set-diff+intersection!
+         char-set-difference
+         char-set-difference!
+         char-set-every
+         char-set-filter
+         char-set-filter!
+         char-set-fold
+         char-set-for-each
+         char-set-hash
+         char-set-intersection
+         char-set-intersection!
+         char-set-map
+         char-set-ref
+         char-set-size
+         char-set-unfold
+         char-set-unfold!
+         char-set-union
+         char-set-union!
+         char-set-xor
+         char-set-xor!
+         char-set:ascii
+         char-set:blank
+         char-set:digit
+         char-set:empty
+         char-set:full
+         char-set:graphic
+         char-set:hex-digit
+         char-set:iso-control
+         char-set:letter
+         char-set:letter+digit
+         char-set:lower-case
+         char-set:printing
+         char-set:punctuation
+         char-set:symbol
+         char-set:title-case
+         char-set:upper-case
+         char-set:whitespace
+         char-set<=
+         char-set=
+         char-set?
+         end-of-char-set?
+         list->char-set
+         list->char-set!
+         string->char-set
+         string->char-set!
+         ucs-range->char-set
+         ucs-range->char-set!)
+  (begin
+    (define (char-set . chars)
+      (list->char-set chars))
+    ))
\ No newline at end of file

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index f0fe91efea35abbd6622e78df5634a8f41201acc..dcf606f259dce2e8011a1c9e8c8cfbab1fc2974f 100644 (file)
--- a/src/runtime/char-set.scm
+++ b/src/runtime/char-set.scm
@@ -255,6 +255,16 @@ USA.
 
 (define-integrable (reverse-ilist-cons start end ilist)
   (cons end (cons start ilist)))
+
+(define (ilist= ilist1 ilist2)
+  (if (and (pair? ilist1) (pair? ilist2))
+      (and (fix:= (car ilist1) (car ilist2))
+          (ilist= (cdr ilist1) (cdr ilist2)))
+      (and (null? ilist1) (null? ilist2))))
+
+(define (ilist<= ilist1 ilist2)
+  (ilist= (ilist-union (ilist-difference ilist2 ilist1) ilist1)
+         ilist2))
 \f
 (define (ilist-combiner combine)
 
@@ -465,6 +475,16 @@ USA.
             (cdr char-sets))
       #t))
 
+(define (char-set<= . char-sets)
+  (if (and (pair? char-sets)
+          (pair? (cdr char-sets)))
+      (let loop ((ilists (map char-set->list char-sets)))
+       (and (ilist<= (car ilists) (cadr ilists))
+            (if (pair? (cdr ilists))
+                (loop (cdr ilists))
+                #t)))
+      #t))
+
 (define (char-set-hash char-set #!optional modulus)
   (let ((hash
         (primitive-object-hash-2 (%char-set-low char-set)
@@ -675,24 +695,8 @@ USA.
                      (char-set->list base-set))
                  char-set)))
 
-(define (compute-char-set procedure)
-
-  (define (find-start cp end ilist)
-    (if (fix:< cp end)
-       (if (procedure cp)
-           (find-end (fix:+ cp 1) end cp ilist)
-           (find-start (fix:+ cp 1) end ilist))
-       ilist))
-
-  (define (find-end cp end start ilist)
-    (if (fix:< cp end)
-       (if (procedure cp)
-           (find-end (fix:+ cp 1) end start ilist)
-           (find-start (fix:+ cp 1) end (ilist-cons cp start ilist)))
-       (ilist-cons end start ilist)))
-
-  (ilist->char-set
-   (reverse! (find-start #xE000 #x110000 (find-start 0 #xD800 '())))))
+(define (compute-char-set proc)
+  (char-set-filter proc char-set:full))
 
 (define (ucs-range->char-set lower upper #!optional error? base-set)
   (declare (ignore error?))
@@ -717,85 +721,19 @@ USA.
   (list->string (char-set->list char-set)))
 
 (define (char-set->ilist char-set)
-  (reverse!
-   (%high->ilist (%char-set-high char-set)
-                (%low->ilist (%char-set-low char-set)))))
-
-(define (%low->ilist low)
-  (let ((low-limit (%low-limit low)))
-
-    (define (find-start i result)
-      (if (fix:< i low-limit)
-         (if (%low-ref low i)
-             (find-end i result)
-             (find-start (fix:+ i 1) result))
-         result))
-
-    (define (find-end start result)
-      (let loop ((i (fix:+ start 1)))
-       (if (fix:< i low-limit)
-           (if (%low-ref low i)
-               (loop (fix:+ i 1))
-               (find-start i (reverse-ilist-cons start i result)))
-           (reverse-ilist-cons start low-limit result))))
-
-    (find-start 0 '())))
-
-(define (%high->ilist high result)
-  (let ((n (%high-limit high)))
-
-    (define (loop i result)
-      (if (fix:< i n)
-         (loop (fix:+ i 1)
-               (cons (%high-ref high i) result))
-         result))
-
-    (if (and (fix:> n 0)
-            (pair? result)
-            (fix:= (%high-ref high 0) (car result)))
-       (loop 1 (cdr result))
-       (loop 0 result))))
+  (char-set-range-fold-right ilist-cons '() char-set))
 
 (define (char-set->code-points char-set)
-  (let loop ((ilist (char-set->ilist char-set)) (ranges '()))
-    (if (pair? ilist)
-       (loop (cddr ilist)
-             (cons (make-range (car ilist) (cadr ilist))
-                   ranges))
-       (reverse! ranges))))
-\f
+  (char-set-range-fold-right (lambda (start end cpl)
+                              (cons (make-range start end) cpl))
+                            '()
+                            char-set))
+
 (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-limit 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))))
+  (char-set-range-fold (lambda (start end size)
+                        (fix:+ (fix:- end start) size))
+                      0
+                      char-set))
 
 (define (char-set-count pred char-set)
   (char-set-fold-right (lambda (char count)

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 5ecbbdcaa1b3865ce149b801ca6b78918cf608cd..955d5eaa10ab39d727d06190e9a7c91f7e3aac3c 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -794,6 +794,7 @@ USA.
 (define-feature 'srfi-6 always)  ;Basic String Ports
 (define-feature 'srfi-8 always)  ;RECEIVE
 (define-feature 'srfi-9 always)  ;DEFINE-RECORD-TYPE
+(define-feature 'srfi-14 always) ;Character-set Library
 (define-feature 'srfi-23 always) ;ERROR
 (define-feature 'srfi-27 always) ;Sources of Random Bits
 (define-feature 'srfi-30 always) ;Nested Multi-Line Comments (#| ... |#)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 3c0bf41e6122caf2a856e239bd566ec389c75a81..773349ac49aae5d982fdfbe29613d44653532a34 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1682,6 +1682,7 @@ USA.
          char-set:hex-digit            ;SRFI 14
          char-set:iso-control          ;SRFI 14
          char-set:wsp
+         char-set<=                    ;SRFI 14
          char-set=                     ;SRFI 14
          char-set?                     ;SRFI 14
          char-sets-disjoint?