Author: yamakenz
Date: Tue Jul 10 06:33:08 2007
New Revision: 4685
Added:
sigscheme-trunk/lib/sigscheme-init.scm
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/lib/Makefile.am
sigscheme-trunk/src/module-srfi1.c
sigscheme-trunk/src/sigscheme.c
sigscheme-trunk/src/sigschemeinternal.h
sigscheme-trunk/test/test-sscm-ext.scm
Log:
* This commit add new character codec procedure with-char-codec
* src/sigschemeinternal.h
- (SCM_PREPEND_SCMLIBDIR): New macro
* src/sigscheme.c
- (scm_initialize_internal): Require sigscheme-init.scm
* src/module-srfi1.c
- (scm_initialize_srfi1): Rewrite with SCM_PREPEND_SCMLIBDIR()
* lib/Makefile.am
- (dist_scmlib_DATA): Add sigscheme-init.scm
* lib/sigscheme-init.scm
- New file
- (%with-guarded-char-codec, with-char-codec): New procedure
* test/test-sscm-ext.scm
- Add tests for with-char-codec
* NEWS
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Tue Jul 10 06:33:08 2007
@@ -6,8 +6,8 @@
- New syntax let-optionals* compatible with Gauche for optional argument
processing
- - New character codec procedures %%current-char-codec and
- %%set-current-char-codec!
+ - New character codec procedures %%current-char-codec,
+ %%set-current-char-codec! and with-char-codec
- New debugging procedures %pair-mutable?, %string-mutable?,
%vector-mutable?
Modified: sigscheme-trunk/lib/Makefile.am
==============================================================================
--- sigscheme-trunk/lib/Makefile.am (original)
+++ sigscheme-trunk/lib/Makefile.am Tue Jul 10 06:33:08 2007
@@ -1,6 +1,6 @@
EXTRA_DIST = slib.scm
-dist_scmlib_DATA = srfi-1.scm
+dist_scmlib_DATA = sigscheme-init.scm srfi-1.scm
# Install into master package's pkgdatadir if --with-master-pkg is specified
# e.g.)
Added: sigscheme-trunk/lib/sigscheme-init.scm
==============================================================================
--- (empty file)
+++ sigscheme-trunk/lib/sigscheme-init.scm Tue Jul 10 06:33:08 2007
@@ -0,0 +1,51 @@
+;; Filename : sigscheme-init.scm
+;; About : Initialize file for SigScheme
+;;
+;; Copyright (c) 2007 SigScheme Project <uim-en AT googlegroups.com>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(define %with-guarded-char-codec
+ (lambda (thunk)
+ (let ((orig-codec (%%current-char-codec))
+ (thunk-codec (%%current-char-codec)))
+ (dynamic-wind
+ (lambda ()
+ (%%set-current-char-codec! thunk-codec))
+ thunk
+ (lambda ()
+ (set! thunk-codec (%%current-char-codec))
+ (%%set-current-char-codec! orig-codec))))))
+
+(define with-char-codec
+ (lambda (codec thunk)
+ (%with-guarded-char-codec
+ (lambda ()
+ (%%set-current-char-codec! codec)
+ (thunk)))))
Modified: sigscheme-trunk/src/module-srfi1.c
==============================================================================
--- sigscheme-trunk/src/module-srfi1.c (original)
+++ sigscheme-trunk/src/module-srfi1.c Tue Jul 10 06:33:08 2007
@@ -69,7 +69,7 @@
SCM_EXPORT void
scm_initialize_srfi1(void)
{
- scm_require(SCMLIBDIR "/srfi-1.scm");
+ scm_require(SCM_PREPEND_SCMLIBDIR("srfi-1.scm"));
scm_define_alias("srfi-1:for-each", "for-each");
scm_define_alias("srfi-1:member", "member");
Modified: sigscheme-trunk/src/sigscheme.c
==============================================================================
--- sigscheme-trunk/src/sigscheme.c (original)
+++ sigscheme-trunk/src/sigscheme.c Tue Jul 10 06:33:08 2007
@@ -338,6 +338,9 @@
if (SCM_PTR_BITS == 64)
scm_provide(CONST_STRING("64bit-addr"));
+ /* Load additional procedures written in Scheme */
+ scm_require(SCM_PREPEND_SCMLIBDIR("sigscheme-init.scm"));
+
return NULL;
}
Modified: sigscheme-trunk/src/sigschemeinternal.h
==============================================================================
--- sigscheme-trunk/src/sigschemeinternal.h (original)
+++ sigscheme-trunk/src/sigschemeinternal.h Tue Jul 10 06:33:08 2007
@@ -267,6 +267,9 @@
#define SCM_LISTLEN_ENCODE_CIRCULAR(len) (SCM_INT_T_MIN)
#define SCM_LISTLEN_ENCODE_ERROR SCM_LISTLEN_ENCODE_CIRCULAR
+/* only string literal is allowed for the arg 'file' */
+#define SCM_PREPEND_SCMLIBDIR(file) (SCMLIBDIR "/" file)
+
/*=======================================
Utils for Procedure Implementation
=======================================*/
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 06:33:08 2007
@@ -57,6 +57,30 @@
(assert-equal? (tn) "UTF-8" (%%set-current-char-codec! "UTF-8"))
(assert-equal? (tn) "UTF-8" (%%current-char-codec))
+;; sigscheme-init.scm
+(tn "with-char-codec")
+(assert-equal? (tn) "UTF-8" (%%current-char-codec))
+(assert-equal? (tn) "ISO-8859-1" (with-char-codec "ISO-8859-1"
+ (lambda ()
+ (%%current-char-codec))))
+(assert-equal? (tn) "UTF-8" (with-char-codec "UTF-8"
+ (lambda ()
+ (%%current-char-codec))))
+(assert-equal? (tn) "UTF-8" (begin
+ (guard (err
+ (else #f))
+ (with-char-codec "ISO-8859-1"
+ (lambda ()
+ (error "error in the thunk"))))
+ (%%current-char-codec)))
+(assert-equal? (tn) "UTF-8" (begin
+ (call-with-current-continuation
+ (lambda (k)
+ (with-char-codec "ISO-8859-1"
+ (lambda ()
+ (k #f)))))
+ (%%current-char-codec)))
+
(tn "let-optionals* invalid forms")
(assert-error (tn) (lambda () (let-optionals* '() ())))
(assert-error (tn) (lambda () (let-optionals* #(0) () #t)))
