[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 MG	43
	44	(define-module (srfi srfi-14))
	45
	46	(export
	47	;;; General procedures
	48	char-set?
	49	char-set=
	50	char-set<=
	51	char-set-hash
	52
	53	;;; Iterating over character sets
	54	char-set-cursor
	55	char-set-ref
	56	char-set-cursor-next
	57	end-of-char-set?
	58	char-set-fold
	59	char-set-unfold char-set-unfold!
	60	char-set-for-each
	61	char-set-map
	62
	63	;;; Creating character sets
	64	char-set-copy
	65	char-set
	66	list->char-set list->char-set!
8b19021c	67	string->char-set string->char-set!
ca003b26 MG	68	char-set-filter char-set-filter!
	69	ucs-range->char-set ucs-range->char-set!
	70	->char-set
	71
	72	;;; Querying character sets
	73	char-set-size
	74	char-set-count
	75	char-set->list
	76	char-set->string
	77	char-set-contains?
	78	char-set-every
	79	char-set-any
	80
	81	;;; Character set algebra
	82	char-set-adjoin char-set-adjoin!
	83	char-set-delete char-set-delete!
	84	char-set-complement
	85	char-set-union
	86	char-set-intersection
	87	char-set-difference
	88	char-set-xor
	89	char-set-diff+intersection
	90	char-set-complement!
	91	char-set-union!
	92	char-set-intersection!
	93	char-set-difference!
	94	char-set-xor!
	95	char-set-diff+intersection!
	96
	97	;;; Standard character sets
	98	char-set:lower-case
	99	char-set:upper-case
	100	char-set:title-case
	101	char-set:letter
	102	char-set:digit
	103	char-set:letter+digit
	104	char-set:graphic
	105	char-set:printing
	106	char-set:whitespace
	107	char-set:iso-control
	108	char-set:punctuation
	109	char-set:symbol
	110	char-set:hex-digit
	111	char-set:blank
	112	char-set:ascii
	113	char-set:empty
	114	char-set:full
	115	)
	116
1b2f40b9 MG	117	(cond-expand-provide (current-module) '(srfi-14))
1b2f40b9 MG	118
dd22a80a	119	(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_14")
ca003b26 MG	120
	121	(define (->char-set x)
	122	(cond
	123	((string? x) (string->char-set x))
	124	((char? x) (char-set x))
	125	((char-set? x) x)
	126	(else (error "invalid argument to `->char-set'"))))
	127
	128	(define char-set:full (ucs-range->char-set 0 256))
	129
	130	(define char-set:lower-case (char-set-filter char-lower-case? char-set:full))
	131
	132	(define char-set:upper-case (char-set-filter char-upper-case? char-set:full))
	133
	134	(define char-set:title-case (char-set))
	135
	136	(define char-set:letter (char-set-union char-set:lower-case
	137	char-set:upper-case))
	138
	139	(define char-set:digit (string->char-set "0123456789"))
	140
	141	(define char-set:letter+digit
	142	(char-set-union char-set:letter char-set:digit))
	143
	144	(define char-set:punctuation (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
	145
	146	(define char-set:symbol (string->char-set "$+<=>^`\|~"))
	147
	148	(define char-set:whitespace (char-set #\space #\newline #\tab #\cr #\vt #\np))
	149
	150	(define char-set:blank (char-set #\space #\tab))
	151
	152	(define char-set:graphic
	153	(char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))
	154
	155	(define char-set:printing
	156	(char-set-union char-set:graphic char-set:whitespace))
	157
	158	(define char-set:iso-control
	159	(char-set-adjoin
	160	(char-set-filter (lambda (ch) (< (char->integer ch) 31)) char-set:full)
	161	(integer->char 127)))
	162
	163	(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
	164
	165	(define char-set:ascii
	166	(char-set-filter (lambda (ch) (< (char->integer ch) 128)) char-set:full))
	167
	168	(define char-set:empty (char-set))