home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / chrset.scm < prev    next >
Text File  |  2001-06-15  |  7KB  |  196 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: chrset.scm,v 14.13 2001/06/15 20:38:37 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Character Sets
  24. ;;; package: (runtime character-set)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define-structure (char-set (type-descriptor char-set-rtd))
  29.   (table #f read-only #t))
  30.  
  31. (define-integrable char-set-table-length 256)
  32.  
  33. (define (char-set . chars)
  34.   (chars->char-set chars))
  35.  
  36. (define (chars->char-set chars)
  37.   (let ((table (make-string char-set-table-length)))
  38.     (vector-8b-fill! table 0 char-set-table-length 0)
  39.     (do ((chars chars (cdr chars)))
  40.     ((not (pair? chars)))
  41.       (vector-8b-set! table
  42.               (let ((code (char->integer (car chars))))
  43.             (if (fix:>= code char-set-table-length)
  44.                 (error:bad-range-argument chars 'CHARS->CHAR-SET))
  45.             code)
  46.               1))
  47.     (make-char-set table)))
  48.  
  49. (define (string->char-set string)
  50.   (let ((table (make-string char-set-table-length)))
  51.     (vector-8b-fill! table 0 char-set-table-length 0)
  52.     (do ((i  (fix:- (string-length string) 1)  (fix:- i 1)))
  53.     ((fix:< i 0))
  54.       (vector-8b-set! table (vector-8b-ref string i) 1))
  55.     (make-char-set table)))
  56.  
  57. (define (ascii-range->char-set lower upper)
  58.   (let ((table (make-string char-set-table-length)))
  59.     (vector-8b-fill! table 0 lower 0)
  60.     (vector-8b-fill! table lower upper 1)
  61.     (vector-8b-fill! table upper char-set-table-length 0)
  62.     (make-char-set table)))
  63.  
  64. (define (predicate->char-set predicate)
  65.   (let ((table (make-string char-set-table-length)))
  66.     (let loop ((code 0))
  67.       (if (fix:< code char-set-table-length)
  68.       (begin
  69.         (vector-8b-set! table
  70.                 code
  71.                 (if (predicate (integer->char code)) 1 0))
  72.         (loop (fix:+ code 1)))))
  73.     (make-char-set table)))
  74.  
  75. (define (char-set-members char-set)
  76.   (if (not (char-set? char-set))
  77.       (error:wrong-type-argument char-set "character set" 'CHAR-SET-MEMBERS))
  78.   (let ((table (char-set-table char-set)))
  79.     (let loop ((code char-set-table-length) (chars '()))
  80.       (if (fix:< 0 code)
  81.       (loop (fix:- code 1)
  82.         (if (fix:zero? (vector-8b-ref table (fix:- code 1)))
  83.             chars
  84.             (cons (integer->char (fix:- code 1)) chars)))
  85.       chars))))
  86.  
  87. (define (char-set-member? char-set char)
  88.   (if (not (char-set? char-set))
  89.       (error:wrong-type-argument char-set "character set" 'CHAR-SET-MEMBER?))
  90.   (let ((code (char->integer char)))
  91.     (and (fix:< code char-set-table-length)
  92.      (not (fix:zero? (vector-8b-ref (char-set-table char-set) code))))))
  93.  
  94. (define (char-set-invert char-set)
  95.   (predicate->char-set
  96.    (lambda (char)
  97.      (not (char-set-member? char-set char)))))
  98.  
  99. (define (char-set-union . char-sets)
  100.   (predicate->char-set
  101.    (lambda (char)
  102.      (there-exists? char-sets
  103.        (lambda (char-set)
  104.      (char-set-member? char-set char))))))
  105.  
  106. (define (char-set-intersection . char-sets)
  107.   (predicate->char-set
  108.    (lambda (char)
  109.      (for-all? char-sets
  110.        (lambda (char-set)
  111.      (char-set-member? char-set char))))))
  112.  
  113. (define (char-set-difference include exclude)
  114.   (predicate->char-set
  115.    (lambda (char)
  116.      (and (char-set-member? include char)
  117.       (not (char-set-member? exclude char))))))
  118.  
  119. ;;;; System Character Sets
  120.  
  121. (define char-set:upper-case)
  122. (define char-set:lower-case)
  123. (define char-set:numeric)
  124. (define char-set:graphic)
  125. (define char-set:whitespace)
  126. (define char-set:alphabetic)
  127. (define char-set:alphanumeric)
  128. (define char-set:standard)
  129.  
  130. (define char-set:not-upper-case)
  131. (define char-set:not-lower-case)
  132. (define char-set:not-numeric)
  133. (define char-set:not-graphic)
  134. (define char-set:not-whitespace)
  135. (define char-set:not-alphabetic)
  136. (define char-set:not-alphanumeric)
  137. (define char-set:not-standard)
  138.  
  139. (define char-set:not-01)
  140. (define char-set:newline)
  141.  
  142. (define (initialize-package!)
  143.   ;; This must be first:
  144.   (set! char-set:not-01 (ascii-range->char-set #x02 #x100))
  145.  
  146.   (set! char-set:upper-case (ascii-range->char-set #x41 #x5B))
  147.   (set! char-set:lower-case (ascii-range->char-set #x61 #x7B))
  148.   (set! char-set:numeric (ascii-range->char-set #x30 #x3A))
  149.   (set! char-set:graphic (ascii-range->char-set #x20 #x7F))
  150.   (set! char-set:whitespace
  151.     (char-set #\newline #\tab #\linefeed #\page #\return #\space))
  152.   (set! char-set:alphabetic
  153.     (char-set-union char-set:upper-case char-set:lower-case))
  154.   (set! char-set:alphanumeric
  155.     (char-set-union char-set:alphabetic char-set:numeric))
  156.   (set! char-set:standard
  157.     (char-set-union char-set:graphic (char-set #\newline)))
  158.  
  159.   (set! char-set:not-upper-case   (char-set-invert char-set:upper-case))
  160.   (set! char-set:not-lower-case   (char-set-invert char-set:lower-case))
  161.   (set! char-set:not-numeric      (char-set-invert char-set:numeric))
  162.   (set! char-set:not-graphic      (char-set-invert char-set:graphic))
  163.   (set! char-set:not-whitespace   (char-set-invert char-set:whitespace))
  164.   (set! char-set:not-alphabetic   (char-set-invert char-set:alphabetic))
  165.   (set! char-set:not-alphanumeric (char-set-invert char-set:alphanumeric))
  166.   (set! char-set:not-standard     (char-set-invert char-set:standard))
  167.  
  168.   (set! char-set:newline (char-set #\newline))
  169.   unspecific)
  170.  
  171. (define-integrable (char-upper-case? char)
  172.   (and (fix:<= (char->integer #\A) char)
  173.        (fix:<= char (char->integer #\Z))))
  174.  
  175. (define-integrable (char-lower-case? char)
  176.   (and (fix:<= (char->integer #\a) char)
  177.        (fix:<= char (char->integer #\z))))
  178.  
  179. (define-integrable (char-numeric? char)
  180.   (and (fix:<= (char->integer #\0) char)
  181.        (fix:<= char (char->integer #\9))))
  182.  
  183. (define-integrable (char-graphic? char)
  184.   (char-set-member? char-set:graphic char))
  185.  
  186. (define-integrable (char-whitespace? char)
  187.   (char-set-member? char-set:whitespace char))
  188.  
  189. (define-integrable (char-alphabetic? char)
  190.   (char-set-member? char-set:alphabetic char))
  191.  
  192. (define-integrable (char-alphanumeric? char)
  193.   (char-set-member? char-set:alphanumeric char))
  194.  
  195. (define-integrable (char-standard? char)
  196.   (char-set-member? char-set:standard char))