Author: yamakenz
Date: Tue Jul 10 05:12:38 2007
New Revision: 4684
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/src/module-sscm-ext.c
sigscheme-trunk/src/sigscheme.c
sigscheme-trunk/src/sigscheme.h
sigscheme-trunk/src/sigschemeinternal.h
sigscheme-trunk/test/test-sscm-ext.scm
Log:
* This commit add new character codec procedures %%current-char-codec and
%%set-current-char-codec!
* src/sigscheme.h
- (scm_p_current_char_codec, scm_p_set_current_char_codecx): New function
decl
* src/module-sscm-ext.c
- (scm_p_current_char_codec, scm_p_set_current_char_codecx): New function
* src/sigscheme.c
- (ERRMSG_UNSUPPORTED_ENCODING, ERRMSG_CODEC_SW_NOT_SUPPORTED): Moved to
sigschemeinternal.h
* src/sigschemeinternal.h
- (ERRMSG_UNSUPPORTED_ENCODING, ERRMSG_CODEC_SW_NOT_SUPPORTED): Moved from
sigscheme.c
* test/test-sscm-ext.scm
- Add tests for %%current-char-codec and %%set-current-char-codec!
* NEWS
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Tue Jul 10 05:12:38 2007
@@ -6,6 +6,9 @@
- New syntax let-optionals* compatible with Gauche for optional argument
processing
+ - New character codec procedures %%current-char-codec and
+ %%set-current-char-codec!
+
- New debugging procedures %pair-mutable?, %string-mutable?,
%vector-mutable?
Modified: sigscheme-trunk/src/module-sscm-ext.c
==============================================================================
--- sigscheme-trunk/src/module-sscm-ext.c (original)
+++ sigscheme-trunk/src/module-sscm-ext.c Tue Jul 10 05:12:38 2007
@@ -118,6 +118,41 @@
}
SCM_EXPORT ScmObj
+scm_p_current_char_codec(void)
+{
+ const char *encoding;
+ DECLARE_FUNCTION("%%current-char-codec", procedure_fixed_0);
+
+#if SCM_USE_MULTIBYTE_CHAR
+ encoding = SCM_CHARCODEC_ENCODING(scm_current_char_codec);
+#else
+ encoding = "ISO-8859-1";
+#endif
+
+ return CONST_STRING(encoding);
+}
+
+SCM_EXPORT ScmObj
+scm_p_set_current_char_codecx(ScmObj encoding)
+{
+ ScmCharCodec *codec;
+ DECLARE_FUNCTION("%%set-current-char-codec!", procedure_fixed_1);
+
+ ENSURE_STRING(encoding);
+
+#if SCM_USE_MULTIBYTE_CHAR
+ codec = scm_mb_find_codec(SCM_STRING_STR(encoding));
+ if (!codec)
+ ERR_OBJ(ERRMSG_UNSUPPORTED_ENCODING, encoding);
+ scm_current_char_codec = codec;
+#else
+ ERR(ERRMSG_CODEC_SW_NOT_SUPPORTED);
+#endif
+
+ return scm_p_current_char_codec();
+}
+
+SCM_EXPORT ScmObj
scm_p_prealloc_heaps(ScmObj n)
{
DECLARE_FUNCTION("%%prealloc-heaps", procedure_fixed_1);
Modified: sigscheme-trunk/src/sigscheme.c
==============================================================================
--- sigscheme-trunk/src/sigscheme.c (original)
+++ sigscheme-trunk/src/sigscheme.c Tue Jul 10 05:12:38 2007
@@ -57,10 +57,6 @@
/*=======================================
File Local Macro Definitions
=======================================*/
-#define ERRMSG_UNSUPPORTED_ENCODING "unsupported encoding"
-#define ERRMSG_CODEC_SW_NOT_SUPPORTED \
- "character encoding switching is not supported on this build"
-
#if !SCM_USE_CONTINUATION
#define scm_p_call_with_current_continuation NULL
#define scm_p_dynamic_wind NULL
Modified: sigscheme-trunk/src/sigscheme.h
==============================================================================
--- sigscheme-trunk/src/sigscheme.h (original)
+++ sigscheme-trunk/src/sigscheme.h Tue Jul 10 05:12:38 2007
@@ -1643,6 +1643,8 @@
SCM_EXPORT void scm_require(const char *filename);
SCM_EXPORT ScmObj scm_p_symbol_boundp(ScmObj sym, ScmObj rest);
SCM_EXPORT ScmObj scm_p_current_environment(ScmEvalState *eval_state);
+SCM_EXPORT ScmObj scm_p_current_char_codec(void);
+SCM_EXPORT ScmObj scm_p_set_current_char_codecx(ScmObj encoding);
SCM_EXPORT ScmObj scm_p_prealloc_heaps(ScmObj n);
SCM_EXPORT ScmObj scm_p_pair_mutablep(ScmObj kons);
SCM_EXPORT ScmObj scm_p_fixnum_width(void);
Modified: sigscheme-trunk/src/sigschemeinternal.h
==============================================================================
--- sigscheme-trunk/src/sigschemeinternal.h (original)
+++ sigscheme-trunk/src/sigschemeinternal.h Tue Jul 10 05:12:38 2007
@@ -196,6 +196,9 @@
"proper list required for function call but got"
#define SCM_ERRMSG_NULL_IN_STRING \
"null character in a middle of string is not enabled"
+#define ERRMSG_UNSUPPORTED_ENCODING "unsupported encoding"
+#define ERRMSG_CODEC_SW_NOT_SUPPORTED \
+ "character encoding switching is not supported on this build"
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
/* FIXME: temporary hack. SCM_EOF is only used as an unique ID. */
Modified: sigscheme-trunk/test/test-sscm-ext.scm
==============================================================================
--- sigscheme-trunk/test/test-sscm-ext.scm (original)
+++ sigscheme-trunk/test/test-sscm-ext.scm Tue Jul 10 05:12:38 2007
@@ -42,6 +42,21 @@
(define tn test-name)
(define ud (undef))
+(tn "%%current-char-codec")
+(assert-equal? (tn) "UTF-8" (%%current-char-codec))
+
+(tn "%%set-current-char-codec!")
+(assert-error (tn) (lambda () (%%set-current-char-codec! "")))
+(assert-error (tn) (lambda () (%%set-current-char-codec! "UTF-32")))
+(assert-equal? (tn) "UTF-8" (%%set-current-char-codec! "UTF-8"))
+(assert-equal? (tn) "UTF-8" (%%current-char-codec))
+(assert-equal? (tn) "ISO-8859-1" (%%set-current-char-codec! "ISO-8859-1"))
+(assert-equal? (tn) "ISO-8859-1" (%%current-char-codec))
+(assert-error (tn) (lambda () (%%set-current-char-codec! "UTF-32")))
+(assert-equal? (tn) "ISO-8859-1" (%%current-char-codec))
+(assert-equal? (tn) "UTF-8" (%%set-current-char-codec! "UTF-8"))
+(assert-equal? (tn) "UTF-8" (%%current-char-codec))
+
(tn "let-optionals* invalid forms")
(assert-error (tn) (lambda () (let-optionals* '() ())))
(assert-error (tn) (lambda () (let-optionals* #(0) () #t)))
