[bpt/guile.git] / srfi / srfi-14.scm

;;;; srfi-14.scm --- SRFI-14 procedures for Guile
;;;;
;;;; 	Copyright (C) 2001 Free Software Foundation, Inc.
;;;; 
;;;; This program 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, or
;;;; (at your option) any later version.
;;;; 
;;;; This program 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 this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.

(define-module (srfi srfi-14)
  :export (
;;; General procedures
 char-set?
 char-set=
 char-set<=
 char-set-hash

;;; Iterating over character sets
 char-set-cursor
 char-set-ref
 char-set-cursor-next
 end-of-char-set?
 char-set-fold
 char-set-unfold char-set-unfold!
 char-set-for-each
 char-set-map

;;; Creating character sets
 char-set-copy
 char-set
 list->char-set list->char-set!
 string->char-set string->char-set!
 char-set-filter char-set-filter!
 ucs-range->char-set ucs-range->char-set!
 ->char-set

;;; Querying character sets
 char-set-size
 char-set-count
 char-set->list
 char-set->string
 char-set-contains?
 char-set-every
 char-set-any

;;; Character set algebra
 char-set-adjoin char-set-adjoin!
 char-set-delete char-set-delete!
 char-set-complement
 char-set-union
 char-set-intersection
 char-set-difference
 char-set-xor
 char-set-diff+intersection
 char-set-complement!
 char-set-union!
 char-set-intersection!
 char-set-difference!
 char-set-xor!
 char-set-diff+intersection!

;;; Standard character sets
 char-set:lower-case
 char-set:upper-case
 char-set:title-case
 char-set:letter
 char-set:digit
 char-set:letter+digit
 char-set:graphic
 char-set:printing
 char-set:whitespace
 char-set:iso-control
 char-set:punctuation
 char-set:symbol
 char-set:hex-digit
 char-set:blank
 char-set:ascii
 char-set:empty
 char-set:full
 ))

(cond-expand-provide (current-module) '(srfi-14))

(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_14")

(define (->char-set x)
  (cond
   ((string? x)   (string->char-set x))
   ((char? x)     (char-set x))
   ((char-set? x) x)
   (else (error "invalid argument to `->char-set'"))))

(define char-set:full (ucs-range->char-set 0 256))

(define char-set:lower-case (char-set-filter char-lower-case? char-set:full))

(define char-set:upper-case (char-set-filter char-upper-case? char-set:full))

(define char-set:title-case (char-set))

(define char-set:letter (char-set-union char-set:lower-case
					char-set:upper-case))

(define char-set:digit (string->char-set "0123456789"))

(define char-set:letter+digit
  (char-set-union char-set:letter char-set:digit))

(define char-set:punctuation (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))

(define char-set:symbol (string->char-set "$+<=>^`|~"))

(define char-set:whitespace (char-set #\space #\newline #\tab #\cr #\vt #\np))

(define char-set:blank (char-set #\space #\tab))

(define char-set:graphic
  (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))

(define char-set:printing
  (char-set-union char-set:graphic char-set:whitespace))

(define char-set:iso-control
  (char-set-adjoin
   (char-set-filter (lambda (ch) (< (char->integer ch) 31)) char-set:full)
   (integer->char 127)))

(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))

(define char-set:ascii
  (char-set-filter (lambda (ch) (< (char->integer ch) 128)) char-set:full))

(define char-set:empty (char-set))
Commit	Line	Data
ca003b26 MG	1	;;;; srfi-14.scm --- SRFI-14 procedures for Guile
	2	;;;;
	3	;;;; Copyright (C) 2001 Free Software Foundation, Inc.
	4	;;;;
	5	;;;; This program is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU General Public License as
	7	;;;; published by the Free Software Foundation; either version 2, or
	8	;;;; (at your option) any later version.
	9	;;;;
	10	;;;; This program is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU General Public License
	16	;;;; along with this software; see the file COPYING. If not, write to
	17	;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
	18	;;;; Boston, MA 02111-1307 USA
f480396b MV	19	;;;;
	20	;;;; As a special exception, the Free Software Foundation gives permission
	21	;;;; for additional uses of the text contained in its release of GUILE.
	22	;;;;
	23	;;;; The exception is that, if you link the GUILE library with other files
	24	;;;; to produce an executable, this does not by itself cause the
	25	;;;; resulting executable to be covered by the GNU General Public License.
	26	;;;; Your use of that executable is in no way restricted on account of
	27	;;;; linking the GUILE library code into it.
	28	;;;;
	29	;;;; This exception does not however invalidate any other reasons why
	30	;;;; the executable file might be covered by the GNU General Public License.
	31	;;;;
	32	;;;; This exception applies only to the code released by the
	33	;;;; Free Software Foundation under the name GUILE. If you copy
	34	;;;; code from other Free Software Foundation releases into a copy of
	35	;;;; GUILE, as the General Public License permits, the exception does
	36	;;;; not apply to the code that you add in this way. To avoid misleading
	37	;;;; anyone as to the status of such modified files, you must delete
	38	;;;; this exception notice from them.
	39	;;;;
	40	;;;; If you write modifications of your own for GUILE, it is your choice
	41	;;;; whether to permit this exception to apply to your modifications.
	42	;;;; If you do not wish that, delete this exception notice.
ca003b26	43
1a179b03 MD	44	(define-module (srfi srfi-14)
1a179b03 MD	45	:export (
ca003b26 MG	46	;;; General procedures
	47	char-set?
	48	char-set=
	49	char-set<=
	50	char-set-hash
	51
	52	;;; Iterating over character sets
	53	char-set-cursor
	54	char-set-ref
	55	char-set-cursor-next
	56	end-of-char-set?
	57	char-set-fold
	58	char-set-unfold char-set-unfold!
	59	char-set-for-each
	60	char-set-map
	61
	62	;;; Creating character sets
	63	char-set-copy
	64	char-set
	65	list->char-set list->char-set!
8b19021c	66	string->char-set string->char-set!
ca003b26 MG	67	char-set-filter char-set-filter!
	68	ucs-range->char-set ucs-range->char-set!
	69	->char-set
	70
	71	;;; Querying character sets
	72	char-set-size
	73	char-set-count
	74	char-set->list
	75	char-set->string
	76	char-set-contains?
	77	char-set-every
	78	char-set-any
	79
	80	;;; Character set algebra
	81	char-set-adjoin char-set-adjoin!
	82	char-set-delete char-set-delete!
	83	char-set-complement
	84	char-set-union
	85	char-set-intersection
	86	char-set-difference
	87	char-set-xor
	88	char-set-diff+intersection
	89	char-set-complement!
	90	char-set-union!
	91	char-set-intersection!
	92	char-set-difference!
	93	char-set-xor!
	94	char-set-diff+intersection!
	95
	96	;;; Standard character sets
	97	char-set:lower-case
	98	char-set:upper-case
	99	char-set:title-case
	100	char-set:letter
	101	char-set:digit
	102	char-set:letter+digit
	103	char-set:graphic
	104	char-set:printing
	105	char-set:whitespace
	106	char-set:iso-control
	107	char-set:punctuation
	108	char-set:symbol
	109	char-set:hex-digit
	110	char-set:blank
	111	char-set:ascii
	112	char-set:empty
	113	char-set:full
1a179b03	114	))
ca003b26	115
1b2f40b9 MG	116	(cond-expand-provide (current-module) '(srfi-14))
1b2f40b9 MG	117
dd22a80a	118	(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_14")
ca003b26 MG	119
	120	(define (->char-set x)
	121	(cond
	122	((string? x) (string->char-set x))
	123	((char? x) (char-set x))
	124	((char-set? x) x)
	125	(else (error "invalid argument to `->char-set'"))))
	126
	127	(define char-set:full (ucs-range->char-set 0 256))
	128
	129	(define char-set:lower-case (char-set-filter char-lower-case? char-set:full))
	130
	131	(define char-set:upper-case (char-set-filter char-upper-case? char-set:full))
	132
	133	(define char-set:title-case (char-set))
	134
	135	(define char-set:letter (char-set-union char-set:lower-case
	136	char-set:upper-case))
	137
	138	(define char-set:digit (string->char-set "0123456789"))
	139
	140	(define char-set:letter+digit
	141	(char-set-union char-set:letter char-set:digit))
	142
	143	(define char-set:punctuation (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
	144
	145	(define char-set:symbol (string->char-set "$+<=>^`\|~"))
	146
	147	(define char-set:whitespace (char-set #\space #\newline #\tab #\cr #\vt #\np))
	148
	149	(define char-set:blank (char-set #\space #\tab))
	150
	151	(define char-set:graphic
	152	(char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))
	153
	154	(define char-set:printing
	155	(char-set-union char-set:graphic char-set:whitespace))
	156
	157	(define char-set:iso-control
	158	(char-set-adjoin
	159	(char-set-filter (lambda (ch) (< (char->integer ch) 31)) char-set:full)
	160	(integer->char 127)))
	161
	162	(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
	163
	164	(define char-set:ascii
	165	(char-set-filter (lambda (ch) (< (char->integer ch) 128)) char-set:full))
	166
	167	(define char-set:empty (char-set))