1 /*===========================================================================
2 * Filename : port.c
3 * About : R5RS ports
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include <stddef.h>
41 #include <stdio.h>
42
43 #include "sigscheme.h"
44 #include "sigschemeinternal.h"
45 #if SCM_USE_MULTIBYTE_CHAR
46 #include "scmport-mbchar.h"
47 #else /* SCM_USE_MULTIBYTE_CHAR */
48 #include "scmport-sbchar.h"
49 #endif /* SCM_USE_MULTIBYTE_CHAR */
50 #include "scmport-file.h"
51
52 /*=======================================
53 File Local Macro Definitions
54 =======================================*/
55 #define ERRMSG_CANNOT_OPEN_FILE "cannot open file"
56
57 #if !SCM_USE_CHAR
58 #define scm_p_read_char NULL
59 #define scm_p_peek_char NULL
60 #define scm_p_char_readyp NULL
61 #define scm_p_write_char NULL
62 #endif
63
64 /*=======================================
65 File Local Type Definitions
66 =======================================*/
67
68 /*=======================================
69 Variable Definitions
70 =======================================*/
71 #include "functable-r5rs-port.c"
72
73 SCM_DEFINE_EXPORTED_VARS(port);
74
75 #if (SCM_USE_READER || SCM_USE_WRITER)
76 SCM_EXPORT const ScmSpecialCharInfo scm_special_char_table[] = {
77 /* printable characters */
78 {'\"', "\\\"", "\""}, /* 34, R5RS */
79 {'\\', "\\\\", "\\"}, /* 92, R5RS */
80 {' ', " ", "space"}, /* 32, R5RS */
81
82 /* control characters */
83 {'\n', "\\n", "newline"}, /* 10, R5RS */
84 #if SCM_USE_R6RS_NAMED_CHARS
85 {'\0', "\\x00", "nul"}, /* 0 */
86 {'\a', "\\a", "alarm"}, /* 7 */
87 {'\b', "\\b", "backspace"}, /* 8 */
88 {'\t', "\\t", "tab"}, /* 9 */
89 {'\n', "\\n", "linefeed"}, /* 10 */
90 {'\v', "\\v", "vtab"}, /* 11 */
91 {'\f', "\\f", "page"}, /* 12 */
92 {'\r', "\\r", "return"}, /* 13 */
93 {0x1b, "\\x1b", "esc"}, /* 27 */
94 {0x7f, "\\x7f", "delete"}, /* 127 */
95 #endif /* SCM_USE_R6RS_NAMED_CHARS */
96 {0, NULL, NULL}
97 };
98 #endif /* (SCM_USE_READER || SCM_USE_WRITER) */
99
100 /*=======================================
101 File Local Function Declarations
102 =======================================*/
103
104 /*=======================================
105 Function Definitions
106 =======================================*/
107 SCM_EXPORT void
scm_init_port(void)108 scm_init_port(void)
109 {
110 SCM_GLOBAL_VARS_INIT(port);
111
112 scm_register_funcs(scm_functable_r5rs_port);
113
114 #if !SCM_USE_CHAR
115 SCM_SYMBOL_SET_VCELL(scm_intern("read-char"), SCM_UNBOUND);
116 SCM_SYMBOL_SET_VCELL(scm_intern("peek-char"), SCM_UNBOUND);
117 SCM_SYMBOL_SET_VCELL(scm_intern("char-ready?"), SCM_UNBOUND);
118 SCM_SYMBOL_SET_VCELL(scm_intern("write-char"), SCM_UNBOUND);
119 #endif
120
121 scm_fileport_init();
122 #if SCM_USE_MULTIBYTE_CHAR
123 scm_mbcport_init();
124 #else
125 scm_sbcport_init();
126 #endif
127
128 scm_gc_protect_with_init(&scm_in,
129 scm_make_shared_file_port(stdin, "stdin",
130 SCM_PORTFLAG_INPUT));
131 scm_gc_protect_with_init(&scm_out,
132 scm_make_shared_file_port(stdout, "stdout",
133 SCM_PORTFLAG_OUTPUT));
134 scm_gc_protect_with_init(&scm_err,
135 scm_make_shared_file_port(stderr, "stderr",
136 SCM_PORTFLAG_OUTPUT));
137 }
138
139 SCM_EXPORT ScmObj
scm_prepare_port(ScmObj args,ScmObj default_port)140 scm_prepare_port(ScmObj args, ScmObj default_port)
141 {
142 ScmObj port;
143 DECLARE_INTERNAL_FUNCTION("prepare_port");
144
145 ASSERT_PROPER_ARG_LIST(args);
146
147 if (NULLP(args)) {
148 port = default_port;
149 } else {
150 port = POP(args);
151 ASSERT_NO_MORE_ARG(args);
152 ENSURE_PORT(port);
153 }
154
155 return port;
156 }
157
158 SCM_EXPORT ScmCharPort *
scm_make_char_port(ScmBytePort * bport)159 scm_make_char_port(ScmBytePort *bport)
160 {
161 #if SCM_USE_MULTIBYTE_CHAR
162 return ScmMultiByteCharPort_new(bport, scm_current_char_codec);
163 #else
164 return ScmSingleByteCharPort_new(bport);
165 #endif
166 }
167
168 SCM_EXPORT ScmObj
scm_make_shared_file_port(FILE * file,const char * aux_info,enum ScmPortFlag flag)169 scm_make_shared_file_port(FILE *file, const char *aux_info,
170 enum ScmPortFlag flag)
171 {
172 ScmBytePort *bport;
173 ScmCharPort *cport;
174
175 bport = ScmFilePort_new_shared(file, aux_info);
176 cport = scm_make_char_port(bport);
177 return MAKE_PORT(cport, flag);
178 }
179
180 SCM_EXPORT void
scm_port_newline(ScmObj port)181 scm_port_newline(ScmObj port)
182 {
183 scm_port_puts(port, SCM_NEWLINE_STR);
184 scm_port_flush(port); /* required */
185 }
186
187 SCM_EXPORT void
scm_port_close(ScmObj port)188 scm_port_close(ScmObj port)
189 {
190 SCM_ASSERT(SCM_PORTP(port));
191 SCM_ASSERT(SCM_PORT_IMPL(port));
192
193 SCM_CHARPORT_CLOSE(SCM_PORT_IMPL(port));
194 SCM_PORT_SET_IMPL(port, NULL);
195 }
196
197 SCM_EXPORT ScmCharCodec *
scm_port_codec(ScmObj port)198 scm_port_codec(ScmObj port)
199 {
200 SCM_ENSURE_LIVE_PORT(port);
201 return SCM_CHARPORT_CODEC(SCM_PORT_IMPL(port));
202 }
203
204 SCM_EXPORT char *
scm_port_inspect(ScmObj port)205 scm_port_inspect(ScmObj port)
206 {
207 SCM_ENSURE_LIVE_PORT(port);
208 return SCM_CHARPORT_INSPECT(SCM_PORT_IMPL(port));
209 }
210
211 SCM_EXPORT scm_ichar_t
scm_port_get_char(ScmObj port)212 scm_port_get_char(ScmObj port)
213 {
214 SCM_ENSURE_LIVE_PORT(port);
215 return SCM_CHARPORT_GET_CHAR(SCM_PORT_IMPL(port));
216 }
217
218 SCM_EXPORT scm_ichar_t
scm_port_peek_char(ScmObj port)219 scm_port_peek_char(ScmObj port)
220 {
221 SCM_ENSURE_LIVE_PORT(port);
222 return SCM_CHARPORT_PEEK_CHAR(SCM_PORT_IMPL(port));
223 }
224
225 SCM_EXPORT scm_bool
scm_port_char_readyp(ScmObj port)226 scm_port_char_readyp(ScmObj port)
227 {
228 SCM_ENSURE_LIVE_PORT(port);
229 return SCM_CHARPORT_CHAR_READYP(SCM_PORT_IMPL(port));
230 }
231
232 SCM_EXPORT void
scm_port_puts(ScmObj port,const char * str)233 scm_port_puts(ScmObj port, const char *str)
234 {
235 SCM_ENSURE_LIVE_PORT(port);
236 SCM_CHARPORT_PUTS(SCM_PORT_IMPL(port), str);
237 }
238
239 SCM_EXPORT void
scm_port_put_char(ScmObj port,scm_ichar_t ch)240 scm_port_put_char(ScmObj port, scm_ichar_t ch)
241 {
242 SCM_ENSURE_LIVE_PORT(port);
243 SCM_CHARPORT_PUT_CHAR(SCM_PORT_IMPL(port), ch);
244 }
245
246 SCM_EXPORT void
scm_port_flush(ScmObj port)247 scm_port_flush(ScmObj port)
248 {
249 SCM_ENSURE_LIVE_PORT(port);
250 SCM_CHARPORT_FLUSH(SCM_PORT_IMPL(port));
251 }
252
253 /*=======================================
254 R5RS : 6.6 Input and Output
255 =======================================*/
256 /*===========================================================================
257 R5RS : 6.6 Input and Output : 6.6.1 Ports
258 ===========================================================================*/
259 /* call-with-input-file, call-with-output-file, with-input-from-file and
260 * with-output-to-file are implemented in lib/sigscheme-init.scm */
261
262 SCM_EXPORT ScmObj
scm_p_input_portp(ScmObj port)263 scm_p_input_portp(ScmObj port)
264 {
265 DECLARE_FUNCTION("input-port?", procedure_fixed_1);
266
267 ENSURE_PORT(port);
268
269 return MAKE_BOOL(SCM_PORT_FLAG(port) & SCM_PORTFLAG_INPUT);
270 }
271
272 SCM_EXPORT ScmObj
scm_p_output_portp(ScmObj port)273 scm_p_output_portp(ScmObj port)
274 {
275 DECLARE_FUNCTION("output-port?", procedure_fixed_1);
276
277 ENSURE_PORT(port);
278
279 return MAKE_BOOL(SCM_PORT_FLAG(port) & SCM_PORTFLAG_OUTPUT);
280 }
281
282 SCM_EXPORT ScmObj
scm_p_current_input_port(void)283 scm_p_current_input_port(void)
284 {
285 DECLARE_FUNCTION("current-input-port", procedure_fixed_0);
286
287 return scm_in;
288 }
289
290 SCM_EXPORT ScmObj
scm_p_current_output_port(void)291 scm_p_current_output_port(void)
292 {
293 DECLARE_FUNCTION("current-output-port", procedure_fixed_0);
294
295 return scm_out;
296 }
297
298 SCM_EXPORT ScmObj
scm_p_current_error_port(void)299 scm_p_current_error_port(void)
300 {
301 DECLARE_FUNCTION("%%current-error-port", procedure_fixed_0);
302
303 return scm_err;
304 }
305
306 SCM_EXPORT ScmObj
scm_p_set_current_input_portx(ScmObj newport)307 scm_p_set_current_input_portx(ScmObj newport)
308 {
309 DECLARE_FUNCTION("%%set-current-input-port!", procedure_fixed_1);
310
311 SCM_ENSURE_LIVE_PORT(newport);
312 if (!(SCM_PORT_FLAG(newport) & SCM_PORTFLAG_INPUT))
313 ERR_OBJ("input port required but got", newport);
314
315 scm_in = newport;
316
317 return SCM_TRUE;
318 }
319
320 SCM_EXPORT ScmObj
scm_p_set_current_output_portx(ScmObj newport)321 scm_p_set_current_output_portx(ScmObj newport)
322 {
323 DECLARE_FUNCTION("%%set-current-output-port!", procedure_fixed_1);
324
325 SCM_ENSURE_LIVE_PORT(newport);
326 if (!(SCM_PORT_FLAG(newport) & SCM_PORTFLAG_OUTPUT))
327 ERR_OBJ("output port required but got", newport);
328
329 scm_out = newport;
330
331 return SCM_TRUE;
332 }
333
334 SCM_EXPORT ScmObj
scm_p_set_current_error_portx(ScmObj newport)335 scm_p_set_current_error_portx(ScmObj newport)
336 {
337 DECLARE_FUNCTION("%%set-current-error-port!", procedure_fixed_1);
338
339 SCM_ENSURE_LIVE_PORT(newport);
340 if (!(SCM_PORT_FLAG(newport) & SCM_PORTFLAG_OUTPUT))
341 ERR_OBJ("output port required but got", newport);
342
343 scm_err = newport;
344
345 return SCM_TRUE;
346 }
347
348 SCM_EXPORT ScmObj
scm_p_open_input_file(ScmObj filepath)349 scm_p_open_input_file(ScmObj filepath)
350 {
351 ScmBytePort *bport;
352 ScmCharPort *cport;
353 DECLARE_FUNCTION("open-input-file", procedure_fixed_1);
354
355 ENSURE_STRING(filepath);
356
357 bport = ScmFilePort_open_input_file(SCM_STRING_STR(filepath));
358 if (!bport)
359 ERR_OBJ(ERRMSG_CANNOT_OPEN_FILE, filepath);
360 cport = scm_make_char_port(bport);
361
362 return MAKE_PORT(cport, SCM_PORTFLAG_INPUT);
363 }
364
365 SCM_EXPORT ScmObj
scm_p_open_output_file(ScmObj filepath)366 scm_p_open_output_file(ScmObj filepath)
367 {
368 ScmBytePort *bport;
369 ScmCharPort *cport;
370 DECLARE_FUNCTION("open-output-file", procedure_fixed_1);
371
372 ENSURE_STRING(filepath);
373
374 bport = ScmFilePort_open_output_file(SCM_STRING_STR(filepath));
375 if (!bport)
376 ERR_OBJ(ERRMSG_CANNOT_OPEN_FILE, filepath);
377 cport = scm_make_char_port(bport);
378
379 return MAKE_PORT(cport, SCM_PORTFLAG_OUTPUT);
380 }
381
382 SCM_EXPORT ScmObj
scm_p_close_input_port(ScmObj port)383 scm_p_close_input_port(ScmObj port)
384 {
385 scm_int_t flag;
386 DECLARE_FUNCTION("close-input-port", procedure_fixed_1);
387
388 ENSURE_PORT(port);
389
390 flag = SCM_PORT_FLAG(port) & ~SCM_PORTFLAG_LIVE_INPUT;
391 SCM_PORT_SET_FLAG(port, flag);
392 if (!(flag & SCM_PORTFLAG_ALIVENESS_MASK) && SCM_PORT_IMPL(port))
393 scm_port_close(port);
394
395 return SCM_UNDEF;
396 }
397
398 SCM_EXPORT ScmObj
scm_p_close_output_port(ScmObj port)399 scm_p_close_output_port(ScmObj port)
400 {
401 scm_int_t flag;
402 DECLARE_FUNCTION("close-output-port", procedure_fixed_1);
403
404 ENSURE_PORT(port);
405
406 flag = SCM_PORT_FLAG(port) & ~SCM_PORTFLAG_LIVE_OUTPUT;
407 SCM_PORT_SET_FLAG(port, flag);
408 if (!(flag & SCM_PORTFLAG_ALIVENESS_MASK) && SCM_PORT_IMPL(port))
409 scm_port_close(port);
410
411 return SCM_UNDEF;
412 }
413
414 /*===========================================================================
415 R5RS : 6.6 Input and Output : 6.6.2 Input
416 ===========================================================================*/
417 /* scm_p_read() is separated into read.c */
418
419 #if SCM_USE_CHAR
420 SCM_EXPORT ScmObj
scm_p_read_char(ScmObj args)421 scm_p_read_char(ScmObj args)
422 {
423 ScmObj port;
424 scm_ichar_t ch;
425 DECLARE_FUNCTION("read-char", procedure_variadic_0);
426
427 port = scm_prepare_port(args, scm_in);
428
429 ch = scm_port_get_char(port);
430 if (ch == SCM_ICHAR_EOF)
431 return SCM_EOF;
432
433 return MAKE_CHAR(ch);
434 }
435
436 SCM_EXPORT ScmObj
scm_p_peek_char(ScmObj args)437 scm_p_peek_char(ScmObj args)
438 {
439 ScmObj port;
440 scm_ichar_t ch;
441 DECLARE_FUNCTION("peek-char", procedure_variadic_0);
442
443 port = scm_prepare_port(args, scm_in);
444
445 ch = scm_port_peek_char(port);
446 if (ch == SCM_ICHAR_EOF)
447 return SCM_EOF;
448
449 return MAKE_CHAR(ch);
450 }
451 #endif /* SCM_USE_CHAR */
452
453 SCM_EXPORT ScmObj
scm_p_eof_objectp(ScmObj obj)454 scm_p_eof_objectp(ScmObj obj)
455 {
456 DECLARE_FUNCTION("eof-object?", procedure_fixed_1);
457
458 return MAKE_BOOL(EOFP(obj));
459 }
460
461 #if SCM_USE_CHAR
462 SCM_EXPORT ScmObj
scm_p_char_readyp(ScmObj args)463 scm_p_char_readyp(ScmObj args)
464 {
465 ScmObj port;
466 scm_bool ret;
467 DECLARE_FUNCTION("char-ready?", procedure_variadic_0);
468
469 port = scm_prepare_port(args, scm_in);
470 ret = scm_port_char_readyp(port);
471
472 return MAKE_BOOL(ret);
473 }
474 #endif /* SCM_USE_CHAR */
475
476 /*===========================================================================
477 R5RS : 6.6 Input and Output : 6.6.3 Output
478 ===========================================================================*/
479 /* scm_p_write() and scm_p_display() are separated into write.c */
480
481 SCM_EXPORT ScmObj
scm_p_newline(ScmObj args)482 scm_p_newline(ScmObj args)
483 {
484 ScmObj port;
485 DECLARE_FUNCTION("newline", procedure_variadic_0);
486
487 port = scm_prepare_port(args, scm_out);
488 scm_port_newline(port);
489 return SCM_UNDEF;
490 }
491
492 #if SCM_USE_CHAR
493 SCM_EXPORT ScmObj
scm_p_write_char(ScmObj obj,ScmObj args)494 scm_p_write_char(ScmObj obj, ScmObj args)
495 {
496 ScmObj port;
497 DECLARE_FUNCTION("write-char", procedure_variadic_1);
498
499 ENSURE_CHAR(obj);
500
501 port = scm_prepare_port(args, scm_out);
502 scm_port_put_char(port, SCM_CHAR_VALUE(obj));
503 return SCM_UNDEF;
504 }
505 #endif /* SCM_USE_CHAR */
506