1;;  Filename : sigscheme-init.scm
2;;  About    : Initialization file for SigScheme
3;;
4;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
5;;
6;;  All rights reserved.
7;;
8;;  Redistribution and use in source and binary forms, with or without
9;;  modification, are permitted provided that the following conditions
10;;  are met:
11;;
12;;  1. Redistributions of source code must retain the above copyright
13;;     notice, this list of conditions and the following disclaimer.
14;;  2. Redistributions in binary form must reproduce the above copyright
15;;     notice, this list of conditions and the following disclaimer in the
16;;     documentation and/or other materials provided with the distribution.
17;;  3. Neither the name of authors nor the names of its contributors
18;;     may be used to endorse or promote products derived from this software
19;;     without specific prior written permission.
20;;
21;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
22;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
23;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
25;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33
34(define %with-guarded-char-codec
35  (lambda (thunk)
36    (let ((orig-codec (%%current-char-codec))
37          (thunk-codec (%%current-char-codec)))
38      (dynamic-wind
39          (lambda ()
40            (%%set-current-char-codec! thunk-codec))
41          thunk
42          (lambda ()
43            (set! thunk-codec (%%current-char-codec))
44            (%%set-current-char-codec! orig-codec))))))
45
46(define with-char-codec
47  (lambda (codec thunk)
48    (%with-guarded-char-codec
49     (lambda ()
50       (%%set-current-char-codec! codec)
51       (thunk)))))
52
53;; Preserve original C implementation.
54(define %%load load)
55
56;; Recover original char codec when an error is occurred on loading.
57(define load
58  (if (provided? "multibyte-char")
59      (lambda (file)
60        (%with-guarded-char-codec
61         (lambda ()
62           (%%load file))))
63      %%load))
64
65;; R5RS
66(define call-with-input-file
67  (lambda (filename proc)
68    (let* ((port (open-input-file filename))
69           (res (proc port)))
70      (close-input-port port)
71      res)))
72
73;; R5RS
74(define call-with-output-file
75  (lambda (filename proc)
76    (let* ((port (open-output-file filename))
77           (res (proc port)))
78      (close-output-port port)
79      res)))
80
81;; R5RS
82(define with-input-from-file
83  (lambda (file thunk)
84    (let ((orig-port (current-input-port))
85          (thunk-port (current-input-port)))
86      (dynamic-wind
87          (lambda ()
88            (%%set-current-input-port! thunk-port))
89          (lambda ()
90            (let* ((port (open-input-file file))
91                   (res (begin
92                          (set! thunk-port port)
93                          (%%set-current-input-port! thunk-port)
94                          (thunk))))
95              (close-input-port port)
96              res))
97          (lambda ()
98            (%%set-current-input-port! orig-port))))))
99
100;; R5RS
101(define with-output-to-file
102  (lambda (file thunk)
103    (let ((orig-port (current-output-port))
104          (thunk-port (current-output-port)))
105      (dynamic-wind
106          (lambda ()
107            (%%set-current-output-port! thunk-port))
108          (lambda ()
109            (let* ((port (open-output-file file))
110                   (res (begin
111                          (set! thunk-port port)
112                          (%%set-current-output-port! thunk-port)
113                          (thunk))))
114              (close-output-port port)
115              res))
116          (lambda ()
117            (%%set-current-output-port! orig-port))))))
118