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