[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-117-gf209aee
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-117-gf209aee |
|
Date: |
Tue, 08 Nov 2011 00:00:51 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=f209aeee9fc5032863cc07138be927da87d3a091
The branch, master has been updated
via f209aeee9fc5032863cc07138be927da87d3a091 (commit)
via 0607ebbfcf63dc81e4bc2b10f3a8c3bc0d348c09 (commit)
via 4251ae2e282385be6d08b0fffab761fcc0fa93aa (commit)
via c932ce0b559ceb7a14846241d7b1856c7c3eea3b (commit)
via be632904cafd0c5baf38b2ef970acc2c72af6cd3 (commit)
via 0d959103f985bbb60959c7ef4738235527792e47 (commit)
via b262d3065c03cbde552cdfbce5819544f2e2dfea (commit)
via 285ac79b1ae6c502841bd2d175445ec5c599aa1e (commit)
via 19b8d12b165a11d963507e0ed35307f4e719e653 (commit)
from 62bd5d66cb66b695452887374c55d025b8b6efea (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit f209aeee9fc5032863cc07138be927da87d3a091
Author: Andy Wingo <address@hidden>
Date: Tue Nov 8 00:46:41 2011 +0100
locking for write, lfwrite
* libguile/ports.c (scm_c_write_unlocked, scm_c_write)
(scm_lfwrite_unlocked, scm_lfwrite): Add locking and _unlocked
variants. Change uses to _unlocked.
commit 0607ebbfcf63dc81e4bc2b10f3a8c3bc0d348c09
Author: Andy Wingo <address@hidden>
Date: Tue Nov 8 00:36:48 2011 +0100
locking for putc, puts
* libguile/ports.c (scm_putc, scm_puts):
* libguile/ports.h (scm_putc_unlocked, scm_puts_unlocked): Separate into
_unlocked and locked variants. Change all callers to use the
_unlocked versions.
commit 4251ae2e282385be6d08b0fffab761fcc0fa93aa
Author: Andy Wingo <address@hidden>
Date: Tue Nov 8 00:29:46 2011 +0100
locking on port buffering operations
* libguile/ports.c (scm_fill_input_unlocked, scm_fill_input)
(scm_end_input, scm_end_input_unlocked, scm_flush)
(scm_flush_unlocked): Add locking and _unlocked variants.
* libguile/filesys.c:
* libguile/fports.c:
* libguile/gdbint.c:
* libguile/r6rs-ports.c:
* libguile/read.c:
* libguile/rw.c: Adapt callers to use _unlocked variants.
commit c932ce0b559ceb7a14846241d7b1856c7c3eea3b
Author: Andy Wingo <address@hidden>
Date: Tue Nov 8 00:14:16 2011 +0100
locking on unget_byte, ungetc, ungets
* libguile/ports.h:
* libguile/ports.c (scm_unget_byte_unlocked, scm_unget_byte)
(scm_ungetc_unlocked, scm_ungetc, scm_ungets_unlocked, scm_ungets):
Add locking and _unlocked variants.
* libguile/arrays.c:
* libguile/rdelim.c:
* libguile/read.c:
* libguile/vports.c: Adapt callers to use the _unlocked variants.
commit be632904cafd0c5baf38b2ef970acc2c72af6cd3
Author: Andy Wingo <address@hidden>
Date: Mon Nov 7 23:53:06 2011 +0100
locking on scm_c_read, scm_getc
* libguile/ports.c (scm_c_read_unlocked, scm_c_read, scm_getc_unlocked)
(scm_getc): Split getc and read operations into locked and unlocked
variants. Change most uses to use the _unlocked version.
commit 0d959103f985bbb60959c7ef4738235527792e47
Author: Andy Wingo <address@hidden>
Date: Mon Nov 7 20:17:22 2011 +0100
threadsafe get-byte-or-eof, peek-byte-or-eof
* libguile/ports.h (scm_get_byte_or_eof_unlocked):
(scm_peek_byte_or_eof_unlocked): Rename, adding _unlocked.
* libguile/ports.c (scm_get_byte_or_eof, scm_peek_byte_or_eof): Add
locking implementations. Adapt callers to use _unlocked variants;
they will do locking.
* libguile/read.c (read_token, scm_read_semicolon_comment)
(scm_read_shebang): Use unlocked variants. We will add locking
later.
commit b262d3065c03cbde552cdfbce5819544f2e2dfea
Author: Andy Wingo <address@hidden>
Date: Mon Nov 7 20:00:39 2011 +0100
threadsafe port revealed counts
* libguile/ports.h:
* libguile/ports.c (scm_revealed_count, scm_set_port_revealed_x): Make
threadsafe.
(scm_adjust_port_revealed_x): New function, to adjust a port's
revealed count in a threadsafe way.
commit 285ac79b1ae6c502841bd2d175445ec5c599aa1e
Author: Andy Wingo <address@hidden>
Date: Tue Nov 8 00:50:47 2011 +0100
scm_c_lock_port takes a port
* libguile/ports.h (scm_c_lock_port, scm_c_try_lock_port)
(scm_c_unlock_port): Take a port instead of an entry.
commit 19b8d12b165a11d963507e0ed35307f4e719e653
Author: Andy Wingo <address@hidden>
Date: Mon Nov 7 19:48:50 2011 +0100
ports implementation reordering
* libguile/ports.h: Slight reorder.
* libguile/ports.c: Reorder ports implementation to match the header
file. This will make it easier to add locking and _unlocked
variants.
-----------------------------------------------------------------------
Summary of changes:
libguile/arbiters.c | 8 +-
libguile/arrays.c | 34 +-
libguile/backtrace.c | 32 +-
libguile/bitvectors.c | 6 +-
libguile/bytevectors.c | 8 +-
libguile/continuations.c | 8 +-
libguile/control.c | 4 +-
libguile/deprecation.c | 2 +-
libguile/dynl.c | 6 +-
libguile/eval.c | 6 +-
libguile/filesys.c | 10 +-
libguile/fluids.c | 12 +-
libguile/foreign.c | 4 +-
libguile/fports.c | 16 +-
libguile/frames.c | 6 +-
libguile/gdbint.c | 4 +-
libguile/gsubr.c | 8 +-
libguile/guardians.c | 10 +-
libguile/hashtab.c | 6 +-
libguile/hooks.c | 10 +-
libguile/ioext.c | 2 +-
libguile/keywords.c | 4 +-
libguile/load.c | 24 +-
libguile/macros.c | 6 +-
libguile/mallocs.c | 6 +-
libguile/memoize.c | 4 +-
libguile/numbers.c | 10 +-
libguile/objcodes.c | 11 +-
libguile/ports.c | 2740 +++++++++++++++++++++++++---------------------
libguile/ports.h | 61 +-
libguile/print.c | 84 +-
libguile/programs.c | 12 +-
libguile/promises.c | 4 +-
libguile/r6rs-ports.c | 20 +-
libguile/rdelim.c | 6 +-
libguile/read.c | 112 +-
libguile/rw.c | 4 +-
libguile/smob.c | 8 +-
libguile/srcprop.c | 4 +-
libguile/srfi-14.c | 18 +-
libguile/stackchk.c | 6 +-
libguile/strports.c | 2 +-
libguile/struct.c | 20 +-
libguile/threads.c | 14 +-
libguile/throw.c | 2 +-
libguile/values.c | 4 +-
libguile/variable.c | 6 +-
libguile/vm.c | 14 +-
libguile/vports.c | 2 +-
libguile/weak-set.c | 8 +-
libguile/weak-table.c | 8 +-
51 files changed, 1817 insertions(+), 1609 deletions(-)
diff --git a/libguile/arbiters.c b/libguile/arbiters.c
index 5923c71..831e0a2 100644
--- a/libguile/arbiters.c
+++ b/libguile/arbiters.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008, 2011
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -89,11 +89,11 @@ static scm_t_bits scm_tc16_arbiter;
static int
arbiter_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<arbiter ", port);
+ scm_puts_unlocked ("#<arbiter ", port);
if (SCM_ARB_LOCKED (exp))
- scm_puts ("locked ", port);
+ scm_puts_unlocked ("locked ", port);
scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
diff --git a/libguile/arrays.c b/libguile/arrays.c
index cc5c726..bcc351c 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -727,15 +727,15 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int
dim, int pos,
else
{
ssize_t i;
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
i++, pos += h->dims[dim].inc)
{
scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
if (i < h->dims[dim].ubnd)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
}
return 1;
}
@@ -752,7 +752,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate)
scm_array_get_handle (array, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
if (h.ndims != 1 || h.dims[0].lbnd != 0)
scm_intprint (h.ndims, 10, port);
if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
@@ -773,12 +773,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate)
{
if (print_lbnds)
{
- scm_putc ('@', port);
+ scm_putc_unlocked ('@', port);
scm_intprint (h.dims[i].lbnd, 10, port);
}
if (print_lens)
{
- scm_putc (':', port);
+ scm_putc_unlocked (':', port);
scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
10, port);
}
@@ -806,9 +806,9 @@ scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate)
not really the same as Scheme values since they are boxed and
can be modified with array-set!, say.
*/
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
scm_i_print_array_dimension (&h, 0, 0, port, pstate);
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
else
@@ -832,14 +832,14 @@ read_decimal_integer (SCM port, int c, ssize_t *resp)
if (c == '-')
{
sign = -1;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
while ('0' <= c && c <= '9')
{
res = 10*res + c-'0';
got_it = 1;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
if (got_it)
@@ -862,7 +862,7 @@ scm_i_read_array (SCM port, int c)
*/
if (c == '(')
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_vector (scm_read (port));
}
@@ -870,11 +870,11 @@ scm_i_read_array (SCM port, int c)
*/
if (c == 'f')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c != '3' && c != '6')
{
if (c != EOF)
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return SCM_BOOL_F;
}
rank = 1;
@@ -899,7 +899,7 @@ scm_i_read_array (SCM port, int c)
&& tag_len < sizeof tag_buf / sizeof tag_buf[0])
{
tag_buf[tag_len++] = c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
if (tag_len == 0)
tag = SCM_BOOL_T;
@@ -924,7 +924,7 @@ scm_i_read_array (SCM port, int c)
if (c == '@')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &lbnd);
}
@@ -932,7 +932,7 @@ scm_i_read_array (SCM port, int c)
if (c == ':')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &len);
if (len < 0)
scm_i_input_error (NULL, port,
@@ -954,7 +954,7 @@ scm_i_read_array (SCM port, int c)
scm_i_input_error (NULL, port,
"missing '(' in vector or array literal",
SCM_EOL);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
elements = scm_read (port);
if (scm_is_false (shape))
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 4dacae2..351e600 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -59,9 +59,9 @@ static SCM
boot_print_exception (SCM port, SCM frame, SCM key, SCM args)
#define FUNC_NAME "boot-print-exception"
{
- scm_puts ("Throw to key ", port);
+ scm_puts_unlocked ("Throw to key ", port);
scm_write (key, port);
- scm_puts (" with args ", port);
+ scm_puts_unlocked (" with args ", port);
scm_write (args, port);
return SCM_UNSPECIFIED;
}
@@ -207,7 +207,7 @@ indent (int n, SCM port)
{
int i;
for (i = 0; i < n; ++i)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
static void
@@ -223,7 +223,7 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int
indentation, SCM sport, S
{
pstate->level = print_params[i].level - 1;
scm_iprlist (hdr, exp, tlr[0], sport, pstate);
- scm_puts (&tlr[1], sport);
+ scm_puts_unlocked (&tlr[1], sport);
}
else
{
@@ -328,19 +328,19 @@ display_backtrace_file (frame, last_file, port, pstate)
*last_file = file;
- scm_puts ("In ", port);
+ scm_puts_unlocked ("In ", port);
if (scm_is_false (file))
if (scm_is_false (line))
- scm_puts ("unknown file", port);
+ scm_puts_unlocked ("unknown file", port);
else
- scm_puts ("current input", port);
+ scm_puts_unlocked ("current input", port);
else
{
pstate->writingp = 0;
scm_iprin1 (file, port, pstate);
pstate->writingp = 1;
}
- scm_puts (":\n", port);
+ scm_puts_unlocked (":\n", port);
}
static void
@@ -355,9 +355,9 @@ display_backtrace_file_and_line (SCM frame, SCM port,
scm_print_state *pstate)
if (scm_is_false (file))
{
if (scm_is_false (line))
- scm_putc ('?', port);
+ scm_putc_unlocked ('?', port);
else
- scm_puts ("<stdin>", port);
+ scm_puts_unlocked ("<stdin>", port);
}
else
{
@@ -372,7 +372,7 @@ display_backtrace_file_and_line (SCM frame, SCM port,
scm_print_state *pstate)
pstate -> writingp = 1;
}
- scm_putc (':', port);
+ scm_putc_unlocked (':', port);
}
else if (scm_is_true (line))
{
@@ -383,10 +383,10 @@ display_backtrace_file_and_line (SCM frame, SCM port,
scm_print_state *pstate)
}
if (scm_is_false (line))
- scm_puts (" ?", port);
+ scm_puts_unlocked (" ?", port);
else
scm_intprint (scm_to_int (line) + 1, 10, port);
- scm_puts (": ", port);
+ scm_puts_unlocked (": ", port);
}
static void
@@ -413,7 +413,7 @@ display_frame (SCM frame, int n, int nfield, int
indentation,
/* Display an application. */
display_application (frame, nfield + 1 + indentation, sport, port, pstate);
- scm_putc ('\n', port);
+ scm_putc_unlocked ('\n', port);
}
struct display_backtrace_args {
@@ -513,7 +513,7 @@ error_during_backtrace (void *data, SCM tag, SCM throw_args)
{
SCM port = SCM_PACK_POINTER (data);
- scm_puts ("Exception thrown while printing backtrace:\n", port);
+ scm_puts_unlocked ("Exception thrown while printing backtrace:\n", port);
scm_print_exception (port, SCM_BOOL_F, tag, throw_args);
return SCM_UNSPECIFIED;
@@ -574,7 +574,7 @@ SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0,
1, 0,
highlights = SCM_EOL;
scm_newline (port);
- scm_puts ("Backtrace:\n", port);
+ scm_puts_unlocked ("Backtrace:\n", port);
scm_display_backtrace_with_highlights (stack, port, SCM_BOOL_F, SCM_BOOL_F,
highlights);
scm_newline (port);
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 17b0260..12dd136 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -53,12 +53,12 @@ bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
scm_t_uint32 *bits = BITVECTOR_BITS (vec);
size_t i, j;
- scm_puts ("#*", port);
+ scm_puts_unlocked ("#*", port);
for (i = 0; i < word_len; i++, bit_len -= 32)
{
scm_t_uint32 mask = 1;
for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
- scm_putc ((bits[i] & mask)? '1' : '0', port);
+ scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port);
}
return 1;
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 9999b23..17ad442 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -415,17 +415,17 @@ scm_i_print_bytevector (SCM bv, SCM port, scm_print_state
*pstate SCM_UNUSED)
scm_array_get_handle (bv, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_write (scm_array_handle_element_type (&h), port);
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
i <= ubnd; i += inc)
{
if (i > 0)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (scm_array_handle_ref (&h, i), port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 7a842de..8662770 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -174,11 +174,11 @@ continuation_print (SCM obj, SCM port, scm_print_state
*state SCM_UNUSED)
{
scm_t_contregs *continuation = SCM_CONTREGS (obj);
- scm_puts ("#<continuation ", port);
+ scm_puts_unlocked ("#<continuation ", port);
scm_intprint (continuation->num_stack_items, 10, port);
- scm_puts (" @ ", port);
+ scm_puts_unlocked (" @ ", port);
scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
@@ -498,7 +498,7 @@ print_exception_and_backtrace (SCM port, SCM tag, SCM args)
if (should_print_backtrace (tag, stack))
{
- scm_puts ("Backtrace:\n", port);
+ scm_puts_unlocked ("Backtrace:\n", port);
scm_display_backtrace_with_highlights (stack, port,
SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL);
diff --git a/libguile/control.c b/libguile/control.c
index 661de8f..6302c07 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -269,9 +269,9 @@ SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM
args),
void
scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<prompt ", port);
+ scm_puts_unlocked ("#<prompt ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index be5fffc..1622406 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -89,7 +89,7 @@ scm_c_issue_deprecation_warning (const char *msg)
fprintf (stderr, "%s\n", msg);
else
{
- scm_puts (msg, scm_current_error_port ());
+ scm_puts_unlocked (msg, scm_current_error_port ());
scm_newline (scm_current_error_port ());
}
}
diff --git a/libguile/dynl.c b/libguile/dynl.c
index a2ae6e2..72305a4 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -185,11 +185,11 @@ scm_t_bits scm_tc16_dynamic_obj;
static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<dynamic-object ", port);
+ scm_puts_unlocked ("#<dynamic-object ", port);
scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
if (DYNL_HANDLE (exp) == NULL)
- scm_puts (" (unlinked)", port);
- scm_putc ('>', port);
+ scm_puts_unlocked (" (unlinked)", port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/eval.c b/libguile/eval.c
index f73710a..ad0a84a 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -913,16 +913,16 @@ static int
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
SCM args;
- scm_puts ("#<boot-closure ", port);
+ scm_puts_unlocked ("#<boot-closure ", port);
scm_uintprint (SCM_UNPACK (closure), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS
(closure)),
scm_from_latin1_symbol ("_"));
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
/* FIXME: optionals and rests */
scm_display (args, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/filesys.c b/libguile/filesys.c
index f600328..3856b44 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1027,7 +1027,7 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
if (SCM_OPFPORTP (object))
{
- scm_flush (object);
+ scm_flush_unlocked (object);
fdes = SCM_FPORT_FDES (object);
}
else
@@ -1797,12 +1797,12 @@ SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
static int
scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
if (!SCM_DIR_OPEN_P (exp))
- scm_puts ("closed: ", port);
- scm_puts ("directory stream ", port);
+ scm_puts_unlocked ("closed: ", port);
+ scm_puts_unlocked ("directory stream ", port);
scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 661f06c..9446156 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -79,25 +79,25 @@ grow_dynamic_state (SCM state)
void
scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<fluid ", port);
+ scm_puts_unlocked ("#<fluid ", port);
scm_intprint ((int) FLUID_NUM (exp), 10, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
{
- scm_puts ("#<dynamic-state ", port);
+ scm_puts_unlocked ("#<dynamic-state ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<with-fluids ", port);
+ scm_puts_unlocked ("#<with-fluids ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
diff --git a/libguile/foreign.c b/libguile/foreign.c
index e431c50..973bfc3 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -330,9 +330,9 @@ SCM_DEFINE (scm_set_pointer_finalizer_x,
"set-pointer-finalizer!", 2, 0, 0,
void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<pointer 0x", port);
+ scm_puts_unlocked ("#<pointer 0x", port);
scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
diff --git a/libguile/fports.c b/libguile/fports.c
index 02fbb05..683c25b 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -215,7 +215,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
drained = scm_nullstr;
if (SCM_OUTPUT_PORT_P (port))
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->read_buf == pt->putback_buf)
{
@@ -636,7 +636,7 @@ fport_input_waiting (SCM port)
static int
fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
scm_print_port_mode (exp, port);
if (SCM_OPFPORTP (exp))
{
@@ -645,8 +645,8 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
if (scm_is_string (name) || scm_is_symbol (name))
scm_display (name, port);
else
- scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
- scm_putc (' ', port);
+ scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc_unlocked (' ', port);
fdes = (SCM_FSTREAM (exp))->fdes;
#if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
@@ -658,11 +658,11 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
}
else
{
- scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
- scm_putc (' ', port);
+ scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc_unlocked (' ', port);
scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
@@ -717,7 +717,7 @@ fport_seek (SCM port, scm_t_off offset, int whence)
if (offset != 0 || whence != SEEK_CUR)
{
/* could expand to avoid a second seek. */
- scm_end_input (port);
+ scm_end_input_unlocked (port);
result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
}
else
diff --git a/libguile/frames.c b/libguile/frames.c
index 2e83cde..b805137 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -45,12 +45,12 @@ scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
void
scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<frame ", port);
+ scm_puts_unlocked ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
index 196c498..b502c7c 100644
--- a/libguile/gdbint.c
+++ b/libguile/gdbint.c
@@ -150,7 +150,7 @@ gdb_read (char *str)
SCM_BEGIN_FOREIGN_BLOCK;
unmark_port (gdb_input_port);
scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
- scm_puts (str, gdb_input_port);
+ scm_puts_unlocked (str, gdb_input_port);
scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
@@ -213,7 +213,7 @@ gdb_print (SCM obj)
{
scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
- scm_flush (gdb_output_port);
+ scm_flush_unlocked (gdb_output_port);
*(pt->write_buf + pt->read_buf_size) = 0;
SEND_STRING (pt->read_buf);
}
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index ca92cc5..84846cf 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -858,13 +858,13 @@ scm_c_define_gsubr_with_generic (const char *name,
SCM
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
{
- scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
+ scm_puts_unlocked ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
scm_display(req1, scm_cur_outp);
- scm_puts ("\n req2: ", scm_cur_outp);
+ scm_puts_unlocked ("\n req2: ", scm_cur_outp);
scm_display(req2, scm_cur_outp);
- scm_puts ("\n opt: ", scm_cur_outp);
+ scm_puts_unlocked ("\n opt: ", scm_cur_outp);
scm_display(opt, scm_cur_outp);
- scm_puts ("\n rest: ", scm_cur_outp);
+ scm_puts_unlocked ("\n rest: ", scm_cur_outp);
scm_display(rst, scm_cur_outp);
scm_newline(scm_cur_outp);
return SCM_UNSPECIFIED;
diff --git a/libguile/guardians.c b/libguile/guardians.c
index dfc5332..5321378 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -86,16 +86,16 @@ guardian_print (SCM guardian, SCM port, scm_print_state
*pstate SCM_UNUSED)
{
t_guardian *g = GUARDIAN_DATA (guardian);
- scm_puts ("#<guardian ", port);
+ scm_puts_unlocked ("#<guardian ", port);
scm_uintprint ((scm_t_bits) g, 16, port);
- scm_puts (" (reachable: ", port);
+ scm_puts_unlocked (" (reachable: ", port);
scm_display (scm_from_uint (g->live), port);
- scm_puts (" unreachable: ", port);
+ scm_puts_unlocked (" unreachable: ", port);
scm_display (scm_length (g->zombies), port);
- scm_puts (")", port);
+ scm_puts_unlocked (")", port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 55f0881..4091afe 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -167,12 +167,12 @@ scm_i_rehash (SCM table,
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<hash-table ", port);
+ scm_puts_unlocked ("#<hash-table ", port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
- scm_putc ('/', port);
+ scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
diff --git a/libguile/hooks.c b/libguile/hooks.c
index 14335f8..782636e 100644
--- a/libguile/hooks.c
+++ b/libguile/hooks.c
@@ -134,22 +134,22 @@ static int
hook_print (SCM hook, SCM port, scm_print_state *pstate)
{
SCM ls, name;
- scm_puts ("#<hook ", port);
+ scm_puts_unlocked ("#<hook ", port);
scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (hook), 16, port);
ls = SCM_HOOK_PROCEDURES (hook);
while (scm_is_pair (ls))
{
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
name = scm_procedure_name (SCM_CAR (ls));
if (scm_is_true (name))
scm_iprin1 (name, port, pstate);
else
- scm_putc ('?', port);
+ scm_putc_unlocked ('?', port);
ls = SCM_CDR (ls);
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/ioext.c b/libguile/ioext.c
index f2b1d6d..b1addf4 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -95,7 +95,7 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
if (pt->rw_active == SCM_PORT_WRITE)
ptob->flush (new);
else if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (new);
+ scm_end_input_unlocked (new);
ans = dup2 (oldfd, newfd);
if (ans == -1)
SCM_SYSERROR;
diff --git a/libguile/keywords.c b/libguile/keywords.c
index 3b9a922..e4a79ac 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008,
2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -47,7 +47,7 @@ scm_t_bits scm_tc16_keyword;
static int
keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#:", port);
+ scm_puts_unlocked ("#:", port);
scm_display (KEYWORDSYM (exp), port);
return 1;
}
diff --git a/libguile/load.c b/libguile/load.c
index e5126ed..d6c318b 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -663,11 +663,11 @@ compiled_is_fresh (SCM full_filename, SCM
compiled_filename,
else
{
compiled_is_newer = 0;
- scm_puts (";;; note: source file ", scm_current_error_port ());
+ scm_puts_unlocked (";;; note: source file ", scm_current_error_port ());
scm_display (full_filename, scm_current_error_port ());
- scm_puts ("\n;;; newer than compiled ", scm_current_error_port ());
+ scm_puts_unlocked ("\n;;; newer than compiled ",
scm_current_error_port ());
scm_display (compiled_filename, scm_current_error_port ());
- scm_puts ("\n", scm_current_error_port ());
+ scm_puts_unlocked ("\n", scm_current_error_port ());
}
return compiled_is_newer;
@@ -685,7 +685,7 @@ do_try_auto_compile (void *data)
SCM source = SCM_PACK_POINTER (data);
SCM comp_mod, compile_file;
- scm_puts (";;; compiling ", scm_current_error_port ());
+ scm_puts_unlocked (";;; compiling ", scm_current_error_port ());
scm_display (source, scm_current_error_port ());
scm_newline (scm_current_error_port ());
@@ -714,16 +714,16 @@ do_try_auto_compile (void *data)
/* Assume `*current-warning-prefix*' has an appropriate value. */
res = scm_call_n (scm_variable_ref (compile_file), args, 5);
- scm_puts (";;; compiled ", scm_current_error_port ());
+ scm_puts_unlocked (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ());
return res;
}
else
{
- scm_puts (";;; it seems ", scm_current_error_port ());
+ scm_puts_unlocked (";;; it seems ", scm_current_error_port ());
scm_display (source, scm_current_error_port ());
- scm_puts ("\n;;; is part of the compiler; skipping auto-compilation\n",
+ scm_puts_unlocked ("\n;;; is part of the compiler; skipping
auto-compilation\n",
scm_current_error_port ());
return SCM_BOOL_F;
}
@@ -738,16 +738,16 @@ auto_compile_catch_handler (void *data, SCM tag, SCM
throw_args)
oport = scm_open_output_string ();
scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
- scm_puts (";;; WARNING: compilation of ", scm_current_error_port ());
+ scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_error_port
());
scm_display (source, scm_current_error_port ());
- scm_puts (" failed:\n", scm_current_error_port ());
+ scm_puts_unlocked (" failed:\n", scm_current_error_port ());
lines = scm_string_split (scm_get_output_string (oport),
SCM_MAKE_CHAR ('\n'));
for (; scm_is_pair (lines); lines = scm_cdr (lines))
if (scm_c_string_length (scm_car (lines)))
{
- scm_puts (";;; ", scm_current_error_port ());
+ scm_puts_unlocked (";;; ", scm_current_error_port ());
scm_display (scm_car (lines), scm_current_error_port ());
scm_newline (scm_current_error_port ());
}
@@ -765,7 +765,7 @@ SCM_DEFINE (scm_sys_warn_auto_compilation_enabled,
"%warn-auto-compilation-enabl
if (!message_shown)
{
- scm_puts (";;; note: auto-compilation is enabled, set
GUILE_AUTO_COMPILE=0\n"
+ scm_puts_unlocked (";;; note: auto-compilation is enabled, set
GUILE_AUTO_COMPILE=0\n"
";;; or pass the --no-auto-compile argument to
disable.\n",
scm_current_error_port ());
message_shown = 1;
@@ -933,7 +933,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path",
0, 0, 1,
if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
&stat_source, &stat_compiled))
{
- scm_puts (";;; found fresh local cache at ", scm_current_error_port
());
+ scm_puts_unlocked (";;; found fresh local cache at ",
scm_current_error_port ());
scm_display (fallback, scm_current_error_port ());
scm_newline (scm_current_error_port ());
return scm_load_compiled_with_vm (fallback);
diff --git a/libguile/macros.c b/libguile/macros.c
index 5a4b9d6..7423e97 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -49,11 +49,11 @@ static int
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
if (scm_is_false (SCM_MACRO_TYPE (macro)))
- scm_puts ("#<primitive-syntax-transformer ", port);
+ scm_puts_unlocked ("#<primitive-syntax-transformer ", port);
else
- scm_puts ("#<syntax-transformer ", port);
+ scm_puts_unlocked ("#<syntax-transformer ", port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/mallocs.c b/libguile/mallocs.c
index 6a366ae..bd8aee8 100644
--- a/libguile/mallocs.c
+++ b/libguile/mallocs.c
@@ -1,5 +1,5 @@
/* classes: src_files
- * Copyright (C) 1995,1997,1998,2000,2001, 2006 Free Software Foundation, Inc.
+ * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -46,9 +46,9 @@ scm_t_bits scm_tc16_malloc;
static int
malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts("#<malloc ", port);
+ scm_puts_unlocked("#<malloc ", port);
scm_uintprint (SCM_SMOB_DATA (exp), 16, port);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
return 1;
}
diff --git a/libguile/memoize.c b/libguile/memoize.c
index e5ed629..9a2caad 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -148,9 +148,9 @@ static const char *const memoized_tags[] =
static int
scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<memoized ", port);
+ scm_puts_unlocked ("#<memoized ", port);
scm_write (scm_unmemoize_expression (memoized), port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 96e1765..54351d6 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5318,7 +5318,7 @@ int
scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
@@ -5326,7 +5326,7 @@ void
scm_i_print_double (double val, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port);
}
int
@@ -5334,7 +5334,7 @@ scm_print_complex (SCM sexp, SCM port, scm_print_state
*pstate SCM_UNUSED)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
@@ -5342,7 +5342,7 @@ void
scm_i_print_complex (double real, double imag, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port);
}
int
@@ -5360,7 +5360,7 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
{
char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
scm_remember_upto_here_1 (exp);
- scm_lfwrite (str, (size_t) strlen (str), port);
+ scm_lfwrite_unlocked (str, (size_t) strlen (str), port);
free (str);
return !0;
}
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index f026783..27ea111 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -355,9 +355,10 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
cookie[SCM_OBJCODE_WORD_SIZE_OFFSET] = word_size;
- scm_c_write (port, cookie, strlen (SCM_OBJCODE_COOKIE));
- scm_c_write (port, SCM_OBJCODE_DATA (objcode),
- sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
+ scm_c_write_unlocked (port, cookie, strlen (SCM_OBJCODE_COOKIE));
+ scm_c_write_unlocked (port, SCM_OBJCODE_DATA (objcode),
+ sizeof (struct scm_objcode)
+ + SCM_OBJCODE_TOTAL_LEN (objcode));
return SCM_UNSPECIFIED;
}
@@ -366,9 +367,9 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
void
scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<objcode ", port);
+ scm_puts_unlocked ("#<objcode ", port);
scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
diff --git a/libguile/ports.c b/libguile/ports.c
index 9b00cc0..a95774b 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -230,7 +230,7 @@ scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM))
void
scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port,
- scm_print_state *pstate))
+ scm_print_state *pstate))
{
scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->print = print;
}
@@ -242,26 +242,25 @@ scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM,
SCM))
}
void
-scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
+scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
{
- scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->flush = flush;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->close = close;
}
void
-scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int
offset))
+scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
{
- scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->end_input = end_input;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->flush = flush;
}
void
-scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
+scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int
offset))
{
- scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->close = close;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->end_input = end_input;
}
void
-scm_set_port_seek (scm_t_bits tc,
- scm_t_off (*seek) (SCM, scm_t_off, int))
+scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM, scm_t_off, int))
{
scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->seek = seek;
}
@@ -280,128 +279,6 @@ scm_set_port_input_waiting (scm_t_bits tc, int
(*input_waiting) (SCM))
-SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
- (SCM port),
- "Return @code{#t} if a character is ready on input @var{port}\n"
- "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
- "@code{#t} then the next @code{read-char} operation on\n"
- "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
- "port at end of file then @code{char-ready?} returns @code{#t}.\n"
- "\n"
- "@code{char-ready?} exists to make it possible for a\n"
- "program to accept characters from interactive ports without\n"
- "getting stuck waiting for input. Any input editors associated\n"
- "with such ports must make sure that characters whose existence\n"
- "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
- "If @code{char-ready?} were to return @code{#f} at end of file,\n"
- "a port at end of file would be indistinguishable from an\n"
- "interactive port that has no ready characters.")
-#define FUNC_NAME s_scm_char_ready_p
-{
- scm_t_port *pt;
-
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- /* It's possible to close the current input port, so validate even in
- this case. */
- SCM_VALIDATE_OPINPORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
-
- /* if the current read buffer is filled, or the
- last pushed-back char has been read and the saved buffer is
- filled, result is true. */
- if (pt->read_pos < pt->read_end
- || (pt->read_buf == pt->putback_buf
- && pt->saved_read_pos < pt->saved_read_end))
- return SCM_BOOL_T;
- else
- {
- scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
-
- if (ptob->input_waiting)
- return scm_from_bool(ptob->input_waiting (port));
- else
- return SCM_BOOL_T;
- }
-}
-#undef FUNC_NAME
-
-/* move up to read_len chars from port's putback and/or read buffers
- into memory starting at dest. returns the number of chars moved. */
-size_t
-scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- size_t chars_read = 0;
- size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
-
- if (from_buf > 0)
- {
- memcpy (dest, pt->read_pos, from_buf);
- pt->read_pos += from_buf;
- chars_read += from_buf;
- read_len -= from_buf;
- dest += from_buf;
- }
-
- /* if putback was active, try the real input buffer too. */
- if (pt->read_buf == pt->putback_buf)
- {
- from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
- if (from_buf > 0)
- {
- memcpy (dest, pt->saved_read_pos, from_buf);
- pt->saved_read_pos += from_buf;
- chars_read += from_buf;
- }
- }
- return chars_read;
-}
-
-/* Clear a port's read buffers, returning the contents. */
-SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
- (SCM port),
- "This procedure clears a port's input buffers, similar\n"
- "to the way that force-output clears the output buffer. The\n"
- "contents of the buffers are returned as a single string, e.g.,\n"
- "\n"
- "@lisp\n"
- "(define p (open-input-file ...))\n"
- "(drain-input p) => empty string, nothing buffered yet.\n"
- "(unread-char (read-char p) p)\n"
- "(drain-input p) => initial chars from p, up to the buffer size.\n"
- "@end lisp\n\n"
- "Draining the buffers may be useful for cleanly finishing\n"
- "buffered I/O so that the file descriptor can be used directly\n"
- "for further input.")
-#define FUNC_NAME s_scm_drain_input
-{
- SCM result;
- char *data;
- scm_t_port *pt;
- long count;
-
- SCM_VALIDATE_OPINPORT (1, port);
- pt = SCM_PTAB_ENTRY (port);
-
- count = pt->read_end - pt->read_pos;
- if (pt->read_buf == pt->putback_buf)
- count += pt->saved_read_end - pt->saved_read_pos;
-
- if (count)
- {
- result = scm_i_make_string (count, &data, 0);
- scm_take_from_input_buffers (port, data, count);
- }
- else
- result = scm_nullstr;
-
- return result;
-}
-#undef FUNC_NAME
-
-
/* Standard ports --- current input, output, error, and more(!). */
static SCM cur_inport_fluid = SCM_BOOL_F;
@@ -540,18 +417,94 @@ scm_i_dynwind_current_load_port (SCM port)
scm_dynwind_fluid (cur_loadport_fluid, port);
}
+
-/* The port table --- an array of pointers to ports. */
-/*
- We need a global registry of ports to flush them all at exit, and to
- get all the ports matching a file descriptor.
+/* Retrieving a port's mode. */
+
+/* Return the flags that characterize a port based on the mode
+ * string used to open a file for that port.
+ *
+ * See PORT FLAGS in scm.h
*/
+
+static long
+scm_i_mode_bits_n (SCM modes)
+{
+ return (SCM_OPN
+ | (scm_i_string_contains_char (modes, 'r')
+ || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
+ | (scm_i_string_contains_char (modes, 'w')
+ || scm_i_string_contains_char (modes, 'a')
+ || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
+ | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
+ | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
+}
+
+long
+scm_mode_bits (char *modes)
+{
+ return scm_i_mode_bits (scm_from_locale_string (modes));
+}
+
+long
+scm_i_mode_bits (SCM modes)
+{
+ long bits;
+
+ if (!scm_is_string (modes))
+ scm_wrong_type_arg_msg (NULL, 0, modes, "string");
+
+ bits = scm_i_mode_bits_n (modes);
+ scm_remember_upto_here_1 (modes);
+ return bits;
+}
+
+/* Return the mode flags from an open port.
+ * Some modes such as "append" are only used when opening
+ * a file and are not returned here. */
+
+SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
+ (SCM port),
+ "Return the port modes associated with the open port @var{port}.\n"
+ "These will not necessarily be identical to the modes used when\n"
+ "the port was opened, since modes such as \"append\" which are\n"
+ "used only during port creation are not retained.")
+#define FUNC_NAME s_scm_port_mode
+{
+ char modes[4];
+ modes[0] = '\0';
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPPORT (1, port);
+ if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
+ if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "r+");
+ else
+ strcpy (modes, "r");
+ }
+ else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "w");
+ if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
+ strcat (modes, "0");
+
+ return scm_from_latin1_string (modes);
+}
+#undef FUNC_NAME
+
+
+
+
+/* The port table --- a weak set of all ports.
+
+ We need a global registry of ports to flush them all at exit, and to
+ get all the ports matching a file descriptor. */
SCM scm_i_port_weak_set;
+
-/* Port finalization. */
+/* Port finalization. */
static void finalize_port (GC_PTR, GC_PTR);
@@ -610,7 +563,6 @@ finalize_port (GC_PTR ptr, GC_PTR data)
}
-
SCM
@@ -699,133 +651,68 @@ scm_i_remove_port (SCM port)
#undef FUNC_NAME
-void
-scm_port_non_buffer (scm_t_port *pt)
-{
- pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
- pt->write_buf = pt->write_pos = &pt->shortbuf;
- pt->read_buf_size = pt->write_buf_size = 1;
- pt->write_end = pt->write_buf + pt->write_buf_size;
-}
-
-/* Revealed counts --- an oddity inherited from SCSH. */
-/* Find a port in the table and return its revealed count.
- Also used by the garbage collector.
- */
+/* Predicates. */
-int
-scm_revealed_count (SCM port)
+SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
+ (SCM x),
+ "Return a boolean indicating whether @var{x} is a port.\n"
+ "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
+ "@var{x}))}.")
+#define FUNC_NAME s_scm_port_p
{
- return SCM_REVEALED(port);
+ return scm_from_bool (SCM_PORTP (x));
}
+#undef FUNC_NAME
-
-
-/* Return the revealed count for a port. */
-
-SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
- (SCM port),
- "Return the revealed count for @var{port}.")
-#define FUNC_NAME s_scm_port_revealed
+SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an input port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_input_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (scm_revealed_count (port));
+ return scm_from_bool (SCM_INPUT_PORT_P (x));
}
#undef FUNC_NAME
-/* Set the revealed count for a port. */
-SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
- (SCM port, SCM rcount),
- "Sets the revealed count for a port to a given value.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_set_port_revealed_x
+SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an output port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_output_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_REVEALED (port) = scm_to_int (rcount);
- return SCM_UNSPECIFIED;
+ x = SCM_COERCE_OUTPORT (x);
+ return scm_from_bool (SCM_OUTPUT_PORT_P (x));
}
#undef FUNC_NAME
-
-
-/* Retrieving a port's mode. */
-
-/* Return the flags that characterize a port based on the mode
- * string used to open a file for that port.
- *
- * See PORT FLAGS in scm.h
- */
-
-static long
-scm_i_mode_bits_n (SCM modes)
-{
- return (SCM_OPN
- | (scm_i_string_contains_char (modes, 'r')
- || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
- | (scm_i_string_contains_char (modes, 'w')
- || scm_i_string_contains_char (modes, 'a')
- || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
- | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
- | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
-}
-
-long
-scm_mode_bits (char *modes)
-{
- return scm_i_mode_bits (scm_from_locale_string (modes));
-}
-
-long
-scm_i_mode_bits (SCM modes)
+SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
+ (SCM port),
+ "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
+ "open.")
+#define FUNC_NAME s_scm_port_closed_p
{
- long bits;
-
- if (!scm_is_string (modes))
- scm_wrong_type_arg_msg (NULL, 0, modes, "string");
-
- bits = scm_i_mode_bits_n (modes);
- scm_remember_upto_here_1 (modes);
- return bits;
+ SCM_VALIDATE_PORT (1, port);
+ return scm_from_bool (!SCM_OPPORTP (port));
}
+#undef FUNC_NAME
-/* Return the mode flags from an open port.
- * Some modes such as "append" are only used when opening
- * a file and are not returned here. */
-
-SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
- (SCM port),
- "Return the port modes associated with the open port @var{port}.\n"
- "These will not necessarily be identical to the modes used when\n"
- "the port was opened, since modes such as \"append\" which are\n"
- "used only during port creation are not retained.")
-#define FUNC_NAME s_scm_port_mode
+SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_eof_object_p
{
- char modes[4];
- modes[0] = '\0';
-
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPPORT (1, port);
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "r+");
- else
- strcpy (modes, "r");
- }
- else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "w");
- if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
- strcat (modes, "0");
-
- return scm_from_latin1_string (modes);
+ return scm_from_bool (SCM_EOF_OBJECT_P (x));
}
#undef FUNC_NAME
+
/* Closing ports. */
/* scm_close_port
@@ -890,610 +777,463 @@ SCM_DEFINE (scm_close_output_port, "close-output-port",
1, 0, 0,
}
#undef FUNC_NAME
-struct for_each_data
-{
- void (*proc) (void *data, SCM p);
- void *data;
-};
-static SCM
-for_each_trampoline (void *data, SCM port, SCM result)
-{
- struct for_each_data *d = data;
-
- d->proc (d->data, port);
+
- return result;
-}
+/* Encoding characters to byte streams, and decoding byte streams to
+ characters. */
-void
-scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
-{
- struct for_each_data d;
-
- d.proc = proc;
- d.data = data;
+/* A fluid specifying the default encoding for newly created ports. If it is
+ a string, that is the encoding. If it is #f, it is in the "native"
+ (Latin-1) encoding. */
+SCM_VARIABLE (default_port_encoding_var, "%default-port-encoding");
- scm_c_weak_set_fold (for_each_trampoline, &d, SCM_EOL,
- scm_i_port_weak_set);
-}
+static int scm_port_encoding_init = 0;
-static void
-scm_for_each_trampoline (void *data, SCM port)
+/* Use ENCODING as the default encoding for future ports. */
+void
+scm_i_set_default_port_encoding (const char *encoding)
{
- scm_call_1 (SCM_PACK_POINTER (data), port);
+ if (!scm_port_encoding_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
+ scm_misc_error (NULL, "tried to set port encoding fluid before it is
initialized",
+ SCM_EOL);
+
+ if (encoding == NULL
+ || !strcmp (encoding, "ASCII")
+ || !strcmp (encoding, "ANSI_X3.4-1968")
+ || !strcmp (encoding, "ISO-8859-1"))
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
+ else
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
+ scm_from_locale_string (encoding));
}
-SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
- (SCM proc),
- "Apply @var{proc} to each port in the Guile port table\n"
- "in turn. The return value is unspecified. More specifically,\n"
- "@var{proc} is applied exactly once to every port that exists\n"
- "in the system at the time @var{port-for-each} is invoked.\n"
- "Changes to the port table while @var{port-for-each} is running\n"
- "have no effect as far as @var{port-for-each} is concerned.")
-#define FUNC_NAME s_scm_port_for_each
+/* Return the name of the default encoding for newly created ports; a
+ return value of NULL means "ISO-8859-1". */
+const char *
+scm_i_default_port_encoding (void)
{
- SCM_VALIDATE_PROC (1, proc);
+ if (!scm_port_encoding_init)
+ return NULL;
+ else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
+ return NULL;
+ else
+ {
+ SCM encoding;
- scm_c_port_for_each (scm_for_each_trampoline, SCM_UNPACK_POINTER (proc));
-
- return SCM_UNSPECIFIED;
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
+ if (!scm_is_string (encoding))
+ return NULL;
+ else
+ return scm_i_string_chars (encoding);
+ }
}
-#undef FUNC_NAME
-
-
-/* Utter miscellany. Gosh, we should clean this up some time. */
-
-SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an input port, otherwise return\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
-#define FUNC_NAME s_scm_input_port_p
+void
+scm_i_set_port_encoding_x (SCM port, const char *encoding)
{
- return scm_from_bool (SCM_INPUT_PORT_P (x));
-}
-#undef FUNC_NAME
+ scm_t_port *pt;
+ iconv_t new_input_cd, new_output_cd;
-SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an output port, otherwise return\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
-#define FUNC_NAME s_scm_output_port_p
-{
- x = SCM_COERCE_OUTPORT (x);
- return scm_from_bool (SCM_OUTPUT_PORT_P (x));
-}
-#undef FUNC_NAME
+ new_input_cd = (iconv_t) -1;
+ new_output_cd = (iconv_t) -1;
-SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
- (SCM x),
- "Return a boolean indicating whether @var{x} is a port.\n"
- "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
- "@var{x}))}.")
-#define FUNC_NAME s_scm_port_p
-{
- return scm_from_bool (SCM_PORTP (x));
-}
-#undef FUNC_NAME
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
-SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
- (SCM port),
- "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
- "open.")
-#define FUNC_NAME s_scm_port_closed_p
-{
- SCM_VALIDATE_PORT (1, port);
- return scm_from_bool (!SCM_OPPORTP (port));
-}
-#undef FUNC_NAME
+ if (encoding == NULL)
+ encoding = "ISO-8859-1";
-SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
- "return @code{#f}.")
-#define FUNC_NAME s_scm_eof_object_p
-{
- return scm_from_bool(SCM_EOF_OBJECT_P (x));
-}
-#undef FUNC_NAME
+ if (pt->encoding != encoding)
+ pt->encoding = scm_gc_strdup (encoding, "port");
-SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
- (SCM port),
- "Flush the specified output port, or the current output port if
@var{port}\n"
- "is omitted. The current output buffer contents are passed to
the\n"
- "underlying port implementation (e.g., in the case of fports, the\n"
- "data will be written to the file and the output buffer will be
cleared.)\n"
- "It has no effect on an unbuffered port.\n\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_force_output
-{
- if (SCM_UNBNDP (port))
- port = scm_current_output_port ();
- else
+ /* If ENCODING is UTF-8, then no conversion descriptor is opened
+ because we do I/O ourselves. This saves 100+ KiB for each
+ descriptor. */
+ if (strcmp (encoding, "UTF-8"))
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPOUTPORT (1, port);
+ if (SCM_CELL_WORD_0 (port) & SCM_RDNG)
+ {
+ /* Open an input iconv conversion descriptor, from ENCODING
+ to UTF-8. We choose UTF-8, not UTF-32, because iconv
+ implementations can typically convert from anything to
+ UTF-8, but not to UTF-32 (see
+
<http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
+ new_input_cd = iconv_open ("UTF-8", encoding);
+ if (new_input_cd == (iconv_t) -1)
+ goto invalid_encoding;
+ }
+
+ if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ {
+ new_output_cd = iconv_open (encoding, "UTF-8");
+ if (new_output_cd == (iconv_t) -1)
+ {
+ if (new_input_cd != (iconv_t) -1)
+ iconv_close (new_input_cd);
+ goto invalid_encoding;
+ }
+ }
}
- scm_flush (port);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
+ if (pt->input_cd != (iconv_t) -1)
+ iconv_close (pt->input_cd);
+ if (pt->output_cd != (iconv_t) -1)
+ iconv_close (pt->output_cd);
-static void
-flush_output_port (void *closure, SCM port)
-{
- if (SCM_OPOUTPORTP (port))
- scm_flush (port);
+ pt->input_cd = new_input_cd;
+ pt->output_cd = new_output_cd;
+
+ return;
+
+ invalid_encoding:
+ {
+ SCM err;
+ err = scm_from_locale_string (encoding);
+ scm_misc_error ("scm_i_set_port_encoding_x",
+ "invalid or unknown character encoding ~s",
+ scm_list_1 (err));
+ }
}
-SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
- (),
- "Equivalent to calling @code{force-output} on\n"
- "all open output ports. The return value is unspecified.")
-#define FUNC_NAME s_scm_flush_all_ports
+SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
+ (SCM port),
+ "Returns, as a string, the character encoding that @var{port}\n"
+ "uses to interpret its input and output.\n")
+#define FUNC_NAME s_scm_port_encoding
{
- scm_c_port_for_each (&flush_output_port, NULL);
- return SCM_UNSPECIFIED;
+ scm_t_port *pt;
+ const char *enc;
+
+ SCM_VALIDATE_PORT (1, port);
+
+ pt = SCM_PTAB_ENTRY (port);
+ enc = pt->encoding;
+ if (enc)
+ return scm_from_locale_string (pt->encoding);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
- (SCM port),
- "Return the next character available from @var{port}, updating\n"
- "@var{port} to point to the following character. If no more\n"
- "characters are available, the end-of-file object is returned.\n"
- "\n"
- "When @var{port}'s data cannot be decoded according to its\n"
- "character encoding, a @code{decoding-error} is raised and\n"
- "@var{port} points past the erroneous byte sequence.\n")
-#define FUNC_NAME s_scm_read_char
+SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
+ (SCM port, SCM enc),
+ "Sets the character encoding that will be used to interpret all\n"
+ "port I/O. New ports are created with the encoding\n"
+ "appropriate for the current locale if @code{setlocale} has \n"
+ "been called or ISO-8859-1 otherwise\n"
+ "and this procedure can be used to modify that encoding.\n")
+#define FUNC_NAME s_scm_set_port_encoding_x
{
- scm_t_wchar c;
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- SCM_VALIDATE_OPINPORT (1, port);
- c = scm_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- return SCM_MAKE_CHAR (c);
+ char *enc_str;
+
+ SCM_VALIDATE_PORT (1, port);
+ SCM_VALIDATE_STRING (2, enc);
+
+ enc_str = scm_to_locale_string (enc);
+ scm_i_set_port_encoding_x (port, enc_str);
+ free (enc_str);
+
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-/* Update the line and column number of PORT after consumption of C. */
-static inline void
-update_port_lf (scm_t_wchar c, SCM port)
-{
- switch (c)
- {
- case '\a':
- case EOF:
- break;
- case '\b':
- SCM_DECCOL (port);
- break;
- case '\n':
- SCM_INCLINE (port);
- break;
- case '\r':
- SCM_ZEROCOL (port);
- break;
- case '\t':
- SCM_TABCOL (port);
- break;
- default:
- SCM_INCCOL (port);
- break;
- }
-}
-#define SCM_MBCHAR_BUF_SIZE (4)
+/* This determines how conversions handle unconvertible characters. */
+SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
+static int scm_conversion_strategy_init = 0;
-/* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint.
- UTF8_BUF is assumed to contain a valid UTF-8 sequence. */
-static scm_t_wchar
-utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size)
+scm_t_string_failed_conversion_handler
+scm_i_get_conversion_strategy (SCM port)
{
- scm_t_wchar codepoint;
-
- if (utf8_buf[0] <= 0x7f)
+ SCM encoding;
+
+ if (scm_is_false (port))
{
- assert (size == 1);
- codepoint = utf8_buf[0];
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ {
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
+ if (scm_is_false (encoding))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ return (scm_t_string_failed_conversion_handler) scm_to_int
(encoding);
+ }
}
- else if ((utf8_buf[0] & 0xe0) == 0xc0)
+ else
{
- assert (size == 2);
- codepoint = ((scm_t_wchar) utf8_buf[0] & 0x1f) << 6UL
- | (utf8_buf[1] & 0x3f);
+ scm_t_port *pt;
+ pt = SCM_PTAB_ENTRY (port);
+ return pt->ilseq_handler;
}
- else if ((utf8_buf[0] & 0xf0) == 0xe0)
+
+}
+
+void
+scm_i_set_conversion_strategy_x (SCM port,
+ scm_t_string_failed_conversion_handler handler)
+{
+ SCM strategy;
+ scm_t_port *pt;
+
+ strategy = scm_from_int ((int) handler);
+
+ if (scm_is_false (port))
{
- assert (size == 3);
- codepoint = ((scm_t_wchar) utf8_buf[0] & 0x0f) << 12UL
- | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 6UL
- | (utf8_buf[2] & 0x3f);
+ /* Set the default encoding for future ports. */
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ scm_misc_error (NULL, "tried to set conversion strategy fluid before it
is initialized",
+ SCM_EOL);
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
}
else
{
- assert (size == 4);
- codepoint = ((scm_t_wchar) utf8_buf[0] & 0x07) << 18UL
- | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 12UL
- | ((scm_t_wchar) utf8_buf[2] & 0x3f) << 6UL
- | (utf8_buf[3] & 0x3f);
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+ pt->ilseq_handler = handler;
}
-
- return codepoint;
}
-/* Read a UTF-8 sequence from PORT. On success, return 0 and set
- *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8
- representation, and set *LEN to the length in bytes. Return
- `EILSEQ' on error. */
-static int
-get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
- scm_t_uint8 buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
+ 1, 0, 0, (SCM port),
+ "Returns the behavior of the port when handling a character that\n"
+ "is not representable in the port's current encoding.\n"
+ "It returns the symbol @code{error} if unrepresentable characters\n"
+ "should cause exceptions, @code{substitute} if the port should\n"
+ "try to replace unrepresentable characters with question marks or\n"
+ "approximate characters, or @code{escape} if unrepresentable\n"
+ "characters should be converted to string escapes.\n"
+ "\n"
+ "If @var{port} is @code{#f}, then the current default behavior\n"
+ "will be returned. New ports will have this default behavior\n"
+ "when they are created.\n")
+#define FUNC_NAME s_scm_port_conversion_strategy
{
-#define ASSERT_NOT_EOF(b) \
- if (SCM_UNLIKELY ((b) == EOF)) \
- goto invalid_seq
-#define CONSUME_PEEKED_BYTE() \
- pt->read_pos++
-
- int byte;
- scm_t_port *pt;
+ scm_t_string_failed_conversion_handler h;
- *len = 0;
- pt = SCM_PTAB_ENTRY (port);
+ SCM_VALIDATE_OPPORT (1, port);
- byte = scm_get_byte_or_eof (port);
- if (byte == EOF)
+ if (!scm_is_false (port))
{
- *codepoint = EOF;
- return 0;
+ SCM_VALIDATE_OPPORT (1, port);
}
- buf[0] = (scm_t_uint8) byte;
- *len = 1;
+ h = scm_i_get_conversion_strategy (port);
+ if (h == SCM_FAILED_CONVERSION_ERROR)
+ return scm_from_latin1_symbol ("error");
+ else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
+ return scm_from_latin1_symbol ("substitute");
+ else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ return scm_from_latin1_symbol ("escape");
+ else
+ abort ();
- if (buf[0] <= 0x7f)
- /* 1-byte form. */
- *codepoint = buf[0];
- else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
- {
- /* 2-byte form. */
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+ /* Never gets here. */
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+SCM_DEFINE (scm_set_port_conversion_strategy_x,
"set-port-conversion-strategy!",
+ 2, 0, 0,
+ (SCM port, SCM sym),
+ "Sets the behavior of the interpreter when outputting a character\n"
+ "that is not representable in the port's current encoding.\n"
+ "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
+ "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
+ "when an unconvertible character is encountered. If it is\n"
+ "@code{'substitute}, then unconvertible characters will \n"
+ "be replaced with approximate characters, or with question marks\n"
+ "if no approximately correct character is available.\n"
+ "If it is @code{'escape},\n"
+ "it will appear as a hex escape when output.\n"
+ "\n"
+ "If @var{port} is an open port, the conversion error behavior\n"
+ "is set for that port. If it is @code{#f}, it is set as the\n"
+ "default behavior for any future ports that get created in\n"
+ "this thread.\n")
+#define FUNC_NAME s_scm_set_port_conversion_strategy_x
+{
+ SCM err;
+ SCM qm;
+ SCM esc;
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+ if (!scm_is_false (port))
+ {
+ SCM_VALIDATE_OPPORT (1, port);
+ }
- *codepoint = ((scm_t_wchar) buf[0] & 0x1f) << 6UL
- | (buf[1] & 0x3f);
+ err = scm_from_latin1_symbol ("error");
+ if (scm_is_true (scm_eqv_p (sym, err)))
+ {
+ scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
+ return SCM_UNSPECIFIED;
}
- else if ((buf[0] & 0xf0) == 0xe0)
+
+ qm = scm_from_latin1_symbol ("substitute");
+ if (scm_is_true (scm_eqv_p (sym, qm)))
{
- /* 3-byte form. */
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+ return SCM_UNSPECIFIED;
+ }
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
- || (buf[0] == 0xe0 && byte < 0xa0)
- || (buf[0] == 0xed && byte > 0x9f)))
- goto invalid_seq;
+ esc = scm_from_latin1_symbol ("escape");
+ if (scm_is_true (scm_eqv_p (sym, esc)))
+ {
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ return SCM_UNSPECIFIED;
+ }
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+ SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
- CONSUME_PEEKED_BYTE ();
- buf[2] = (scm_t_uint8) byte;
- *len = 3;
+
- *codepoint = ((scm_t_wchar) buf[0] & 0x0f) << 12UL
- | ((scm_t_wchar) buf[1] & 0x3f) << 6UL
- | (buf[2] & 0x3f);
- }
- else if (buf[0] >= 0xf0 && buf[0] <= 0xf4)
- {
- /* 4-byte form. */
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+/* Revealed counts --- an oddity inherited from SCSH. */
- if (SCM_UNLIKELY (((byte & 0xc0) != 0x80)
- || (buf[0] == 0xf0 && byte < 0x90)
- || (buf[0] == 0xf4 && byte > 0x8f)))
- goto invalid_seq;
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
+ */
+int
+scm_revealed_count (SCM port)
+{
+ int ret;
+
+ scm_c_lock_port (port);
+ ret = SCM_REVEALED (port);
+ scm_c_unlock_port (port);
+
+ return ret;
+}
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
+ (SCM port),
+ "Return the revealed count for @var{port}.")
+#define FUNC_NAME s_scm_port_revealed
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_int (scm_revealed_count (port));
+}
+#undef FUNC_NAME
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
+ (SCM port, SCM rcount),
+ "Sets the revealed count for a port to a given value.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_set_port_revealed_x
+{
+ int r;
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ r = scm_to_int (rcount);
+ scm_c_lock_port (port);
+ SCM_REVEALED (port) = r;
+ scm_c_unlock_port (port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
+ (SCM port, SCM addend),
+ "Add @var{addend} to the revealed count of @var{port}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_set_port_revealed_x
+{
+ int a;
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ a = scm_to_int (addend);
+ scm_c_lock_port (port);
+ SCM_REVEALED (port) += a;
+ scm_c_unlock_port (port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- CONSUME_PEEKED_BYTE ();
- buf[2] = (scm_t_uint8) byte;
- *len = 3;
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+/* Input. */
- CONSUME_PEEKED_BYTE ();
- buf[3] = (scm_t_uint8) byte;
- *len = 4;
+int
+scm_get_byte_or_eof (SCM port)
+{
+ int ret;
- *codepoint = ((scm_t_wchar) buf[0] & 0x07) << 18UL
- | ((scm_t_wchar) buf[1] & 0x3f) << 12UL
- | ((scm_t_wchar) buf[2] & 0x3f) << 6UL
- | (buf[3] & 0x3f);
- }
- else
- goto invalid_seq;
+ scm_c_lock_port (port);
+ ret = scm_get_byte_or_eof_unlocked (port);
+ scm_c_unlock_port (port);
- return 0;
+ return ret;
+}
- invalid_seq:
- /* Here we could choose the consume the faulty byte when it's not a
- valid starting byte, but it's not a requirement. What Section 3.9
- of Unicode 6.0.0 mandates, though, is to not consume a byte that
- would otherwise be a valid starting byte. */
+int
+scm_peek_byte_or_eof (SCM port)
+{
+ int ret;
- return EILSEQ;
+ scm_c_lock_port (port);
+ ret = scm_peek_byte_or_eof_unlocked (port);
+ scm_c_unlock_port (port);
-#undef CONSUME_PEEKED_BYTE
-#undef ASSERT_NOT_EOF
+ return ret;
}
-/* Likewise, read a byte sequence from PORT, passing it through its
- input conversion descriptor. */
-static int
-get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
- char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+/* scm_c_read
+ *
+ * Used by an application to read arbitrary number of bytes from an
+ * SCM port. Same semantics as libc read, except that scm_c_read only
+ * returns less than SIZE bytes if at end-of-file.
+ *
+ * Warning: Doesn't update port line and column counts! */
+
+/* This structure, and the following swap_buffer function, are used
+ for temporarily swapping a port's own read buffer, and the buffer
+ that the caller of scm_c_read provides. */
+struct port_and_swap_buffer
{
scm_t_port *pt;
- int err, byte_read;
- size_t bytes_consumed, output_size;
- char *output;
- scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
-
- pt = SCM_PTAB_ENTRY (port);
+ unsigned char *buffer;
+ size_t size;
+};
- for (output_size = 0, output = (char *) utf8_buf,
- bytes_consumed = 0, err = 0;
- err == 0 && output_size == 0
- && (bytes_consumed == 0 || byte_read != EOF);
- bytes_consumed++)
- {
- char *input;
- size_t input_left, output_left, done;
+static void
+swap_buffer (void *data)
+{
+ struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
+ unsigned char *old_buf = psb->pt->read_buf;
+ size_t old_size = psb->pt->read_buf_size;
- byte_read = scm_get_byte_or_eof (port);
- if (byte_read == EOF)
- {
- if (bytes_consumed == 0)
- {
- *codepoint = (scm_t_wchar) EOF;
- *len = 0;
- return 0;
- }
- else
- continue;
- }
+ /* Make the port use (buffer, size) from the struct. */
+ psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
+ psb->pt->read_buf_size = psb->size;
- buf[bytes_consumed] = byte_read;
+ /* Save the port's old (buffer, size) in the struct. */
+ psb->buffer = old_buf;
+ psb->size = old_size;
+}
- input = buf;
- input_left = bytes_consumed + 1;
- output_left = sizeof (utf8_buf);
+size_t
+scm_c_read_unlocked (SCM port, void *buffer, size_t size)
+#define FUNC_NAME "scm_c_read"
+{
+ scm_t_port *pt;
+ size_t n_read = 0, n_available;
+ struct port_and_swap_buffer psb;
- done = iconv (pt->input_cd, &input, &input_left,
- &output, &output_left);
- if (done == (size_t) -1)
- {
- err = errno;
- if (err == EINVAL)
- /* Missing input: keep trying. */
- err = 0;
- }
- else
- output_size = sizeof (utf8_buf) - output_left;
- }
-
- if (SCM_UNLIKELY (output_size == 0))
- /* An unterminated sequence. */
- err = EILSEQ;
- else if (SCM_LIKELY (err == 0))
- {
- /* Convert the UTF8_BUF sequence to a Unicode code point. */
- *codepoint = utf8_to_codepoint (utf8_buf, output_size);
- *len = bytes_consumed;
- }
-
- return err;
-}
-
-/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
- with the byte representation of the codepoint in PORT's encoding, and
- set *LEN to the length in bytes of that representation. Return 0 on
- success and an errno value on error. */
-static int
-get_codepoint (SCM port, scm_t_wchar *codepoint,
- char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
-{
- int err;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->input_cd == (iconv_t) -1)
- /* Initialize the conversion descriptors, if needed. */
- scm_i_set_port_encoding_x (port, pt->encoding);
-
- /* FIXME: In 2.1, add a flag to determine whether a port is UTF-8. */
- if (pt->input_cd == (iconv_t) -1)
- err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
- else
- err = get_iconv_codepoint (port, codepoint, buf, len);
-
- if (SCM_LIKELY (err == 0))
- update_port_lf (*codepoint, port);
- else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
- {
- *codepoint = '?';
- err = 0;
- update_port_lf (*codepoint, port);
- }
-
- return err;
-}
-
-/* Read a codepoint from PORT and return it. */
-scm_t_wchar
-scm_getc (SCM port)
-#define FUNC_NAME "scm_getc"
-{
- int err;
- size_t len;
- scm_t_wchar codepoint;
- char buf[SCM_MBCHAR_BUF_SIZE];
-
- err = get_codepoint (port, &codepoint, buf, &len);
- if (SCM_UNLIKELY (err != 0))
- /* At this point PORT should point past the invalid encoding, as per
- R6RS-lib Section 8.2.4. */
- scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
-
- return codepoint;
-}
-#undef FUNC_NAME
-
-/* this should only be called when the read buffer is empty. it
- tries to refill the read buffer. it returns the first char from
- the port, which is either EOF or *(pt->read_pos). */
-int
-scm_fill_input (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- assert (pt->read_pos == pt->read_end);
-
- if (pt->read_buf == pt->putback_buf)
- {
- /* finished reading put-back chars. */
- pt->read_buf = pt->saved_read_buf;
- pt->read_pos = pt->saved_read_pos;
- pt->read_end = pt->saved_read_end;
- pt->read_buf_size = pt->saved_read_buf_size;
- if (pt->read_pos < pt->read_end)
- return *(pt->read_pos);
- }
- return SCM_PORT_DESCRIPTOR (port)->fill_input (port);
-}
-
-
-/* scm_lfwrite
- *
- * This function differs from scm_c_write; it updates port line and
- * column. */
-
-void
-scm_lfwrite (const char *ptr, size_t size, SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
-
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
-
- ptob->write (port, ptr, size);
-
- for (; size; ptr++, size--)
- update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
-
-/* Write STR to PORT from START inclusive to END exclusive. */
-void
-scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
-
- if (end == (size_t) -1)
- end = scm_i_string_length (str);
-
- scm_display (scm_c_substring (str, start, end), port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
-
-/* scm_c_read
- *
- * Used by an application to read arbitrary number of bytes from an
- * SCM port. Same semantics as libc read, except that scm_c_read only
- * returns less than SIZE bytes if at end-of-file.
- *
- * Warning: Doesn't update port line and column counts! */
-
-/* This structure, and the following swap_buffer function, are used
- for temporarily swapping a port's own read buffer, and the buffer
- that the caller of scm_c_read provides. */
-struct port_and_swap_buffer
-{
- scm_t_port *pt;
- unsigned char *buffer;
- size_t size;
-};
-
-static void
-swap_buffer (void *data)
-{
- struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
- unsigned char *old_buf = psb->pt->read_buf;
- size_t old_size = psb->pt->read_buf_size;
-
- /* Make the port use (buffer, size) from the struct. */
- psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
- psb->pt->read_buf_size = psb->size;
-
- /* Save the port's old (buffer, size) in the struct. */
- psb->buffer = old_buf;
- psb->size = old_size;
-}
-
-size_t
-scm_c_read (SCM port, void *buffer, size_t size)
-#define FUNC_NAME "scm_c_read"
-{
- scm_t_port *pt;
- size_t n_read = 0, n_available;
- struct port_and_swap_buffer psb;
-
- SCM_VALIDATE_OPINPORT (1, port);
+ SCM_VALIDATE_OPINPORT (1, port);
pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
@@ -1550,7 +1290,7 @@ scm_c_read (SCM port, void *buffer, size_t size)
/* Call scm_fill_input until we have all the bytes that we need,
or we hit EOF. */
- while (pt->read_buf_size && (scm_fill_input (port) != EOF))
+ while (pt->read_buf_size && (scm_fill_input_unlocked (port) != EOF))
{
pt->read_buf_size -= (pt->read_end - pt->read_pos);
pt->read_pos = pt->read_buf = pt->read_end;
@@ -1574,7 +1314,7 @@ scm_c_read (SCM port, void *buffer, size_t size)
that a custom port implementation's entry points (in
particular, fill_input) can rely on the buffer always being
the same as they first set up. */
- while (size && (scm_fill_input (port) != EOF))
+ while (size && (scm_fill_input_unlocked (port) != EOF))
{
n_available = min (size, pt->read_end - pt->read_pos);
memcpy (buffer, pt->read_pos, n_available);
@@ -1589,72 +1329,384 @@ scm_c_read (SCM port, void *buffer, size_t size)
}
#undef FUNC_NAME
-/* scm_c_write
- *
- * Used by an application to write arbitrary number of bytes to an SCM
- * port. Similar semantics as libc write. However, unlike libc
- * write, scm_c_write writes the requested number of bytes and has no
- * return value.
- *
- * Warning: Doesn't update port line and column counts!
- */
-
-void
-scm_c_write (SCM port, const void *ptr, size_t size)
-#define FUNC_NAME "scm_c_write"
+size_t
+scm_c_read (SCM port, void *buffer, size_t size)
{
- scm_t_port *pt;
- scm_t_ptob_descriptor *ptob;
-
- SCM_VALIDATE_OPOUTPORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
- ptob = SCM_PORT_DESCRIPTOR (port);
-
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ size_t ret;
- ptob->write (port, ptr, size);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
-#undef FUNC_NAME
+ scm_c_lock_port (port);
+ ret = scm_c_read_unlocked (port, buffer, size);
+ scm_c_unlock_port (port);
-void
-scm_flush (SCM port)
-{
- SCM_PORT_DESCRIPTOR (port)->flush (port);
+ return ret;
}
-void
-scm_end_input (SCM port)
+/* Update the line and column number of PORT after consumption of C. */
+static inline void
+update_port_lf (scm_t_wchar c, SCM port)
{
- long offset;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->read_buf == pt->putback_buf)
+ switch (c)
{
- offset = pt->read_end - pt->read_pos;
- pt->read_buf = pt->saved_read_buf;
- pt->read_pos = pt->saved_read_pos;
- pt->read_end = pt->saved_read_end;
- pt->read_buf_size = pt->saved_read_buf_size;
+ case '\a':
+ case EOF:
+ break;
+ case '\b':
+ SCM_DECCOL (port);
+ break;
+ case '\n':
+ SCM_INCLINE (port);
+ break;
+ case '\r':
+ SCM_ZEROCOL (port);
+ break;
+ case '\t':
+ SCM_TABCOL (port);
+ break;
+ default:
+ SCM_INCCOL (port);
+ break;
}
- else
- offset = 0;
-
- SCM_PORT_DESCRIPTOR (port)->end_input (port, offset);
}
-
-
+#define SCM_MBCHAR_BUF_SIZE (4)
-void
-scm_unget_byte (int c, SCM port)
-#define FUNC_NAME "scm_unget_byte"
+/* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint.
+ UTF8_BUF is assumed to contain a valid UTF-8 sequence. */
+static scm_t_wchar
+utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size)
{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_wchar codepoint;
+
+ if (utf8_buf[0] <= 0x7f)
+ {
+ assert (size == 1);
+ codepoint = utf8_buf[0];
+ }
+ else if ((utf8_buf[0] & 0xe0) == 0xc0)
+ {
+ assert (size == 2);
+ codepoint = ((scm_t_wchar) utf8_buf[0] & 0x1f) << 6UL
+ | (utf8_buf[1] & 0x3f);
+ }
+ else if ((utf8_buf[0] & 0xf0) == 0xe0)
+ {
+ assert (size == 3);
+ codepoint = ((scm_t_wchar) utf8_buf[0] & 0x0f) << 12UL
+ | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 6UL
+ | (utf8_buf[2] & 0x3f);
+ }
+ else
+ {
+ assert (size == 4);
+ codepoint = ((scm_t_wchar) utf8_buf[0] & 0x07) << 18UL
+ | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 12UL
+ | ((scm_t_wchar) utf8_buf[2] & 0x3f) << 6UL
+ | (utf8_buf[3] & 0x3f);
+ }
+
+ return codepoint;
+}
+
+/* Read a UTF-8 sequence from PORT. On success, return 0 and set
+ *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8
+ representation, and set *LEN to the length in bytes. Return
+ `EILSEQ' on error. */
+static int
+get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
+ scm_t_uint8 buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+{
+#define ASSERT_NOT_EOF(b) \
+ if (SCM_UNLIKELY ((b) == EOF)) \
+ goto invalid_seq
+#define CONSUME_PEEKED_BYTE() \
+ pt->read_pos++
+
+ int byte;
+ scm_t_port *pt;
+
+ *len = 0;
+ pt = SCM_PTAB_ENTRY (port);
+
+ byte = scm_get_byte_or_eof_unlocked (port);
+ if (byte == EOF)
+ {
+ *codepoint = EOF;
+ return 0;
+ }
+
+ buf[0] = (scm_t_uint8) byte;
+ *len = 1;
+
+ if (buf[0] <= 0x7f)
+ /* 1-byte form. */
+ *codepoint = buf[0];
+ else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
+ {
+ /* 2-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
+
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
+
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
+
+ *codepoint = ((scm_t_wchar) buf[0] & 0x1f) << 6UL
+ | (buf[1] & 0x3f);
+ }
+ else if ((buf[0] & 0xf0) == 0xe0)
+ {
+ /* 3-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
+
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
+ || (buf[0] == 0xe0 && byte < 0xa0)
+ || (buf[0] == 0xed && byte > 0x9f)))
+ goto invalid_seq;
+
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
+
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
+
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
+
+ CONSUME_PEEKED_BYTE ();
+ buf[2] = (scm_t_uint8) byte;
+ *len = 3;
+
+ *codepoint = ((scm_t_wchar) buf[0] & 0x0f) << 12UL
+ | ((scm_t_wchar) buf[1] & 0x3f) << 6UL
+ | (buf[2] & 0x3f);
+ }
+ else if (buf[0] >= 0xf0 && buf[0] <= 0xf4)
+ {
+ /* 4-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
+
+ if (SCM_UNLIKELY (((byte & 0xc0) != 0x80)
+ || (buf[0] == 0xf0 && byte < 0x90)
+ || (buf[0] == 0xf4 && byte > 0x8f)))
+ goto invalid_seq;
+
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
+
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
+
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
+
+ CONSUME_PEEKED_BYTE ();
+ buf[2] = (scm_t_uint8) byte;
+ *len = 3;
+
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
+
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
+
+ CONSUME_PEEKED_BYTE ();
+ buf[3] = (scm_t_uint8) byte;
+ *len = 4;
+
+ *codepoint = ((scm_t_wchar) buf[0] & 0x07) << 18UL
+ | ((scm_t_wchar) buf[1] & 0x3f) << 12UL
+ | ((scm_t_wchar) buf[2] & 0x3f) << 6UL
+ | (buf[3] & 0x3f);
+ }
+ else
+ goto invalid_seq;
+
+ return 0;
+
+ invalid_seq:
+ /* Here we could choose the consume the faulty byte when it's not a
+ valid starting byte, but it's not a requirement. What Section 3.9
+ of Unicode 6.0.0 mandates, though, is to not consume a byte that
+ would otherwise be a valid starting byte. */
+
+ return EILSEQ;
+
+#undef CONSUME_PEEKED_BYTE
+#undef ASSERT_NOT_EOF
+}
+
+/* Likewise, read a byte sequence from PORT, passing it through its
+ input conversion descriptor. */
+static int
+get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
+ char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+{
+ scm_t_port *pt;
+ int err, byte_read;
+ size_t bytes_consumed, output_size;
+ char *output;
+ scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
+
+ pt = SCM_PTAB_ENTRY (port);
+
+ for (output_size = 0, output = (char *) utf8_buf,
+ bytes_consumed = 0, err = 0;
+ err == 0 && output_size == 0
+ && (bytes_consumed == 0 || byte_read != EOF);
+ bytes_consumed++)
+ {
+ char *input;
+ size_t input_left, output_left, done;
+
+ byte_read = scm_get_byte_or_eof_unlocked (port);
+ if (byte_read == EOF)
+ {
+ if (bytes_consumed == 0)
+ {
+ *codepoint = (scm_t_wchar) EOF;
+ *len = 0;
+ return 0;
+ }
+ else
+ continue;
+ }
+
+ buf[bytes_consumed] = byte_read;
+
+ input = buf;
+ input_left = bytes_consumed + 1;
+ output_left = sizeof (utf8_buf);
+
+ done = iconv (pt->input_cd, &input, &input_left,
+ &output, &output_left);
+ if (done == (size_t) -1)
+ {
+ err = errno;
+ if (err == EINVAL)
+ /* Missing input: keep trying. */
+ err = 0;
+ }
+ else
+ output_size = sizeof (utf8_buf) - output_left;
+ }
+
+ if (SCM_UNLIKELY (output_size == 0))
+ /* An unterminated sequence. */
+ err = EILSEQ;
+ else if (SCM_LIKELY (err == 0))
+ {
+ /* Convert the UTF8_BUF sequence to a Unicode code point. */
+ *codepoint = utf8_to_codepoint (utf8_buf, output_size);
+ *len = bytes_consumed;
+ }
+
+ return err;
+}
+
+/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
+ with the byte representation of the codepoint in PORT's encoding, and
+ set *LEN to the length in bytes of that representation. Return 0 on
+ success and an errno value on error. */
+static int
+get_codepoint (SCM port, scm_t_wchar *codepoint,
+ char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+{
+ int err;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->input_cd == (iconv_t) -1)
+ /* Initialize the conversion descriptors, if needed. */
+ scm_i_set_port_encoding_x (port, pt->encoding);
+
+ /* FIXME: In 2.1, add a flag to determine whether a port is UTF-8. */
+ if (pt->input_cd == (iconv_t) -1)
+ err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
+ else
+ err = get_iconv_codepoint (port, codepoint, buf, len);
+
+ if (SCM_LIKELY (err == 0))
+ update_port_lf (*codepoint, port);
+ else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
+ {
+ *codepoint = '?';
+ err = 0;
+ update_port_lf (*codepoint, port);
+ }
+
+ return err;
+}
+
+/* Read a codepoint from PORT and return it. */
+scm_t_wchar
+scm_getc_unlocked (SCM port)
+#define FUNC_NAME "scm_getc"
+{
+ int err;
+ size_t len;
+ scm_t_wchar codepoint;
+ char buf[SCM_MBCHAR_BUF_SIZE];
+
+ err = get_codepoint (port, &codepoint, buf, &len);
+ if (SCM_UNLIKELY (err != 0))
+ /* At this point PORT should point past the invalid encoding, as per
+ R6RS-lib Section 8.2.4. */
+ scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
+
+ return codepoint;
+}
+#undef FUNC_NAME
+
+scm_t_wchar
+scm_getc (SCM port)
+{
+ scm_t_wchar ret;
+
+ scm_c_lock_port (port);
+ ret = scm_getc_unlocked (port);
+ scm_c_unlock_port (port);
+
+ return ret;
+}
+
+SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
+ (SCM port),
+ "Return the next character available from @var{port}, updating\n"
+ "@var{port} to point to the following character. If no more\n"
+ "characters are available, the end-of-file object is returned.\n"
+ "\n"
+ "When @var{port}'s data cannot be decoded according to its\n"
+ "character encoding, a @code{decoding-error} is raised and\n"
+ "@var{port} points past the erroneous byte sequence.\n")
+#define FUNC_NAME s_scm_read_char
+{
+ scm_t_wchar c;
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1, port);
+ c = scm_getc_unlocked (port);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ return SCM_MAKE_CHAR (c);
+}
+#undef FUNC_NAME
+
+
+
+
+/* Pushback. */
+
+void
+scm_unget_byte_unlocked (int c, SCM port)
+#define FUNC_NAME "scm_unget_byte"
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->read_buf == pt->putback_buf)
/* already using the put-back buffer. */
@@ -1714,8 +1766,16 @@ scm_unget_byte (int c, SCM port)
}
#undef FUNC_NAME
+void
+scm_unget_byte (int c, SCM port)
+{
+ scm_c_lock_port (port);
+ scm_unget_byte_unlocked (c, port);
+ scm_c_unlock_port (port);
+}
+
void
-scm_ungetc (scm_t_wchar c, SCM port)
+scm_ungetc_unlocked (scm_t_wchar c, SCM port)
#define FUNC_NAME "scm_ungetc"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -1742,7 +1802,7 @@ scm_ungetc (scm_t_wchar c, SCM port)
SCM_BOOL_F, SCM_MAKE_CHAR (c));
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (result[i], port);
+ scm_unget_byte_unlocked (result[i], port);
if (SCM_UNLIKELY (result != result_buf))
free (result);
@@ -1759,9 +1819,16 @@ scm_ungetc (scm_t_wchar c, SCM port)
}
#undef FUNC_NAME
+void
+scm_ungetc (scm_t_wchar c, SCM port)
+{
+ scm_c_lock_port (port);
+ scm_ungetc_unlocked (c, port);
+ scm_c_unlock_port (port);
+}
void
-scm_ungets (const char *s, int n, SCM port)
+scm_ungets_unlocked (const char *s, int n, SCM port)
{
/* This is simple minded and inefficient, but unreading strings is
* probably not a common operation, and remember that line and
@@ -1770,9 +1837,16 @@ scm_ungets (const char *s, int n, SCM port)
* Please feel free to write an optimized version!
*/
while (n--)
- scm_ungetc (s[n], port);
+ scm_ungetc_unlocked (s[n], port);
}
+void
+scm_ungets (const char *s, int n, SCM port)
+{
+ scm_c_lock_port (port);
+ scm_ungets_unlocked (s, n, port);
+ scm_c_unlock_port (port);
+}
SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
(SCM port),
@@ -1814,7 +1888,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
err = get_codepoint (port, &c, bytes, &len);
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (bytes[i], port);
+ scm_unget_byte_unlocked (bytes[i], port);
SCM_COL (port) = column;
SCM_LINUM (port) = line;
@@ -1852,7 +1926,7 @@ SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
c = SCM_CHAR (cobj);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return cobj;
}
#undef FUNC_NAME
@@ -1874,578 +1948,618 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0,
0,
n = scm_i_string_length (str);
while (n--)
- scm_ungetc (scm_i_string_ref (str, n), port);
+ scm_ungetc_unlocked (scm_i_string_ref (str, n), port);
return str;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
- (SCM fd_port, SCM offset, SCM whence),
- "Sets the current position of @var{fd/port} to the integer\n"
- "@var{offset}, which is interpreted according to the value of\n"
- "@var{whence}.\n"
- "\n"
- "One of the following variables should be supplied for\n"
- "@var{whence}:\n"
- "@defvar SEEK_SET\n"
- "Seek from the beginning of the file.\n"
- "@end defvar\n"
- "@defvar SEEK_CUR\n"
- "Seek from the current position.\n"
- "@end defvar\n"
- "@defvar SEEK_END\n"
- "Seek from the end of the file.\n"
- "@end defvar\n"
- "If @var{fd/port} is a file descriptor, the underlying system\n"
- "call is @code{lseek}. @var{port} may be a string port.\n"
- "\n"
- "The value returned is the new position in the file. This means\n"
- "that the current position of a port can be obtained using:\n"
- "@lisp\n"
- "(seek port 0 SEEK_CUR)\n"
- "@end lisp")
-#define FUNC_NAME s_scm_seek
-{
- int how;
-
- fd_port = SCM_COERCE_OUTPORT (fd_port);
- how = scm_to_int (whence);
- if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
- SCM_OUT_OF_RANGE (3, whence);
+
- if (SCM_OPPORTP (fd_port))
- {
- scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port);
- off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
- off_t_or_off64_t rv;
+/* Manipulating the buffers. */
- if (!ptob->seek)
- SCM_MISC_ERROR ("port is not seekable",
- scm_cons (fd_port, SCM_EOL));
- else
- rv = ptob->seek (fd_port, off, how);
- return scm_from_off_t_or_off64_t (rv);
- }
- else /* file descriptor?. */
- {
- off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
- off_t_or_off64_t rv;
- rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
- if (rv == -1)
- SCM_SYSERROR;
- return scm_from_off_t_or_off64_t (rv);
- }
+/* This routine does not take any locks, as it is usually called as part
+ of a port implementation. */
+void
+scm_port_non_buffer (scm_t_port *pt)
+{
+ pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
+ pt->write_buf = pt->write_pos = &pt->shortbuf;
+ pt->read_buf_size = pt->write_buf_size = 1;
+ pt->write_end = pt->write_buf + pt->write_buf_size;
}
-#undef FUNC_NAME
-
-#ifndef O_BINARY
-#define O_BINARY 0
-#endif
-/* Mingw has ftruncate(), perhaps implemented above using chsize, but
- doesn't have the filename version truncate(), hence this code. */
-#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
-static int
-truncate (const char *file, off_t length)
+/* this should only be called when the read buffer is empty. it
+ tries to refill the read buffer. it returns the first char from
+ the port, which is either EOF or *(pt->read_pos). */
+int
+scm_fill_input_unlocked (SCM port)
{
- int ret, fdes;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
- fdes = open (file, O_BINARY | O_WRONLY);
- if (fdes == -1)
- return -1;
+ assert (pt->read_pos == pt->read_end);
- ret = ftruncate (fdes, length);
- if (ret == -1)
+ if (pt->read_buf == pt->putback_buf)
{
- int save_errno = errno;
- close (fdes);
- errno = save_errno;
- return -1;
+ /* finished reading put-back chars. */
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ if (pt->read_pos < pt->read_end)
+ return *(pt->read_pos);
}
-
- return close (fdes);
+ return SCM_PORT_DESCRIPTOR (port)->fill_input (port);
}
-#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
-SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
- (SCM object, SCM length),
- "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
- "filename string, a port object, or an integer file descriptor.\n"
- "The return value is unspecified.\n"
- "\n"
- "For a port or file descriptor @var{length} can be omitted, in\n"
- "which case the file is truncated at the current position (per\n"
- "@code{ftell} above).\n"
- "\n"
- "On most systems a file can be extended by giving a length\n"
- "greater than the current size, but this is not mandatory in the\n"
- "POSIX standard.")
-#define FUNC_NAME s_scm_truncate_file
+int
+scm_fill_input (SCM port)
{
- int rv;
+ int ret;
+
+ scm_c_lock_port (port);
+ ret = scm_fill_input_unlocked (port);
+ scm_c_unlock_port (port);
- /* "object" can be a port, fdes or filename.
+ return ret;
+}
- Negative "length" makes no sense, but it's left to truncate() or
- ftruncate() to give back an error for that (normally EINVAL).
- */
+/* move up to read_len chars from port's putback and/or read buffers
+ into memory starting at dest. returns the number of chars moved. */
+size_t
+scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ size_t chars_read = 0;
+ size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
- if (SCM_UNBNDP (length))
+ if (from_buf > 0)
{
- /* must supply length if object is a filename. */
- if (scm_is_string (object))
- SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
-
- length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
+ memcpy (dest, pt->read_pos, from_buf);
+ pt->read_pos += from_buf;
+ chars_read += from_buf;
+ read_len -= from_buf;
+ dest += from_buf;
}
- object = SCM_COERCE_OUTPORT (object);
- if (scm_is_integer (object))
- {
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
- c_length));
- }
- else if (SCM_OPOUTPORTP (object))
+ /* if putback was active, try the real input buffer too. */
+ if (pt->read_buf == pt->putback_buf)
{
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- scm_t_port *pt = SCM_PTAB_ENTRY (object);
- scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object);
-
- if (!ptob->truncate)
- SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (object);
- else if (pt->rw_active == SCM_PORT_WRITE)
- ptob->flush (object);
-
- ptob->truncate (object, c_length);
- rv = 0;
+ from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->saved_read_pos, from_buf);
+ pt->saved_read_pos += from_buf;
+ chars_read += from_buf;
+ }
}
- else
+ return chars_read;
+}
+
+/* Clear a port's read buffers, returning the contents. */
+SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
+ (SCM port),
+ "This procedure clears a port's input buffers, similar\n"
+ "to the way that force-output clears the output buffer. The\n"
+ "contents of the buffers are returned as a single string, e.g.,\n"
+ "\n"
+ "@lisp\n"
+ "(define p (open-input-file ...))\n"
+ "(drain-input p) => empty string, nothing buffered yet.\n"
+ "(unread-char (read-char p) p)\n"
+ "(drain-input p) => initial chars from p, up to the buffer size.\n"
+ "@end lisp\n\n"
+ "Draining the buffers may be useful for cleanly finishing\n"
+ "buffered I/O so that the file descriptor can be used directly\n"
+ "for further input.")
+#define FUNC_NAME s_scm_drain_input
+{
+ SCM result;
+ char *data;
+ scm_t_port *pt;
+ long count;
+
+ SCM_VALIDATE_OPINPORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
+
+ count = pt->read_end - pt->read_pos;
+ if (pt->read_buf == pt->putback_buf)
+ count += pt->saved_read_end - pt->saved_read_pos;
+
+ if (count)
{
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- char *str = scm_to_locale_string (object);
- int eno;
- SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
- eno = errno;
- free (str);
- errno = eno;
+ result = scm_i_make_string (count, &data, 0);
+ scm_take_from_input_buffers (port, data, count);
}
- if (rv == -1)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
+ else
+ result = scm_nullstr;
+
+ return result;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
- (SCM port),
- "Return the current line number for @var{port}.\n"
- "\n"
- "The first line of a file is 0. But you might want to add 1\n"
- "when printing line numbers, since starting from 1 is\n"
- "traditional in error messages, and likely to be more natural to\n"
- "non-programmers.")
-#define FUNC_NAME s_scm_port_line
+void
+scm_end_input_unlocked (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_long (SCM_LINUM (port));
-}
-#undef FUNC_NAME
+ long offset;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
-SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
- (SCM port, SCM line),
- "Set the current line number for @var{port} to @var{line}. The\n"
- "first line of a file is 0.")
-#define FUNC_NAME s_scm_set_port_line_x
-{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
- return SCM_UNSPECIFIED;
+ if (pt->read_buf == pt->putback_buf)
+ {
+ offset = pt->read_end - pt->read_pos;
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ }
+ else
+ offset = 0;
+
+ SCM_PORT_DESCRIPTOR (port)->end_input (port, offset);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
- (SCM port),
- "Return the current column number of @var{port}.\n"
- "If the number is\n"
- "unknown, the result is #f. Otherwise, the result is a 0-origin
integer\n"
- "- i.e. the first character of the first line is line 0, column
0.\n"
- "(However, when you display a file position, for example in an
error\n"
- "message, we recommend you add 1 to get 1-origin integers. This
is\n"
- "because lines and column numbers traditionally start with 1, and
that is\n"
- "what non-programmers will find most natural.)")
-#define FUNC_NAME s_scm_port_column
+void
+scm_end_input (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (SCM_COL (port));
+ scm_c_lock_port (port);
+ scm_end_input_unlocked (port);
+ scm_c_unlock_port (port);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
- (SCM port, SCM column),
- "Set the current column of @var{port}. Before reading the first\n"
- "character on a line the column should be 0.")
-#define FUNC_NAME s_scm_set_port_column_x
+SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
+ (SCM port),
+ "Flush the specified output port, or the current output port if
@var{port}\n"
+ "is omitted. The current output buffer contents are passed to
the\n"
+ "underlying port implementation (e.g., in the case of fports, the\n"
+ "data will be written to the file and the output buffer will be
cleared.)\n"
+ "It has no effect on an unbuffered port.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_force_output
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+ else
+ {
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ }
+ scm_flush_unlocked (port);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
- (SCM port),
- "Return the filename associated with @var{port}, or @code{#f}\n"
- "if no filename is associated with the port.")
-#define FUNC_NAME s_scm_port_filename
+void
+scm_flush_unlocked (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return SCM_FILENAME (port);
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
- (SCM port, SCM filename),
- "Change the filename associated with @var{port}, using the current
input\n"
- "port if none is specified. Note that this does not change the
port's\n"
- "source of data, but only the value that is returned by\n"
- "@code{port-filename} and reported in diagnostic output.")
-#define FUNC_NAME s_scm_set_port_filename_x
+void
+scm_flush (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- /* We allow the user to set the filename to whatever he likes. */
- SCM_SET_FILENAME (port, filename);
- return SCM_UNSPECIFIED;
+ scm_c_lock_port (port);
+ scm_flush_unlocked (port);
+ scm_c_unlock_port (port);
}
-#undef FUNC_NAME
-/* A fluid specifying the default encoding for newly created ports. If it is
- a string, that is the encoding. If it is #f, it is in the "native"
- (Latin-1) encoding. */
-SCM_VARIABLE (default_port_encoding_var, "%default-port-encoding");
-static int scm_port_encoding_init = 0;
+
+
+/* Output. */
-/* Use ENCODING as the default encoding for future ports. */
void
-scm_i_set_default_port_encoding (const char *encoding)
+scm_putc (char c, SCM port)
{
- if (!scm_port_encoding_init
- || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
- scm_misc_error (NULL, "tried to set port encoding fluid before it is
initialized",
- SCM_EOL);
-
- if (encoding == NULL
- || !strcmp (encoding, "ASCII")
- || !strcmp (encoding, "ANSI_X3.4-1968")
- || !strcmp (encoding, "ISO-8859-1"))
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
- else
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
- scm_from_locale_string (encoding));
+ scm_c_lock_port (port);
+ scm_putc_unlocked (c, port);
+ scm_c_unlock_port (port);
}
-/* Return the name of the default encoding for newly created ports; a
- return value of NULL means "ISO-8859-1". */
-const char *
-scm_i_default_port_encoding (void)
+void
+scm_puts (const char *s, SCM port)
{
- if (!scm_port_encoding_init)
- return NULL;
- else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
- return NULL;
- else
- {
- SCM encoding;
-
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
- if (!scm_is_string (encoding))
- return NULL;
- else
- return scm_i_string_chars (encoding);
- }
+ scm_c_lock_port (port);
+ scm_puts_unlocked (s, port);
+ scm_c_unlock_port (port);
}
-
+
+/* scm_c_write
+ *
+ * Used by an application to write arbitrary number of bytes to an SCM
+ * port. Similar semantics as libc write. However, unlike libc
+ * write, scm_c_write writes the requested number of bytes and has no
+ * return value.
+ *
+ * Warning: Doesn't update port line and column counts!
+ */
void
-scm_i_set_port_encoding_x (SCM port, const char *encoding)
+scm_c_write_unlocked (SCM port, const void *ptr, size_t size)
+#define FUNC_NAME "scm_c_write"
{
scm_t_port *pt;
- iconv_t new_input_cd, new_output_cd;
+ scm_t_ptob_descriptor *ptob;
- new_input_cd = (iconv_t) -1;
- new_output_cd = (iconv_t) -1;
+ SCM_VALIDATE_OPOUTPORT (1, port);
- /* Set the character encoding for this port. */
pt = SCM_PTAB_ENTRY (port);
+ ptob = SCM_PORT_DESCRIPTOR (port);
- if (encoding == NULL)
- encoding = "ISO-8859-1";
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- if (pt->encoding != encoding)
- pt->encoding = scm_gc_strdup (encoding, "port");
+ ptob->write (port, ptr, size);
- /* If ENCODING is UTF-8, then no conversion descriptor is opened
- because we do I/O ourselves. This saves 100+ KiB for each
- descriptor. */
- if (strcmp (encoding, "UTF-8"))
- {
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG)
- {
- /* Open an input iconv conversion descriptor, from ENCODING
- to UTF-8. We choose UTF-8, not UTF-32, because iconv
- implementations can typically convert from anything to
- UTF-8, but not to UTF-32 (see
-
<http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
- new_input_cd = iconv_open ("UTF-8", encoding);
- if (new_input_cd == (iconv_t) -1)
- goto invalid_encoding;
- }
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+#undef FUNC_NAME
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- {
- new_output_cd = iconv_open (encoding, "UTF-8");
- if (new_output_cd == (iconv_t) -1)
- {
- if (new_input_cd != (iconv_t) -1)
- iconv_close (new_input_cd);
- goto invalid_encoding;
- }
- }
- }
+void
+scm_c_write (SCM port, const void *ptr, size_t size)
+{
+ scm_c_lock_port (port);
+ scm_c_write_unlocked (port, ptr, size);
+ scm_c_unlock_port (port);
+}
+
+/* scm_lfwrite
+ *
+ * This function differs from scm_c_write; it updates port line and
+ * column. */
+void
+scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
+
+ ptob->write (port, ptr, size);
+
+ for (; size; ptr++, size--)
+ update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+
+void
+scm_lfwrite (const char *ptr, size_t size, SCM port)
+{
+ scm_c_lock_port (port);
+ scm_lfwrite_unlocked (ptr, size, port);
+ scm_c_unlock_port (port);
+}
- if (pt->input_cd != (iconv_t) -1)
- iconv_close (pt->input_cd);
- if (pt->output_cd != (iconv_t) -1)
- iconv_close (pt->output_cd);
+/* Write STR to PORT from START inclusive to END exclusive. */
+void
+scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
- pt->input_cd = new_input_cd;
- pt->output_cd = new_output_cd;
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- return;
+ if (end == (size_t) -1)
+ end = scm_i_string_length (str);
- invalid_encoding:
- {
- SCM err;
- err = scm_from_locale_string (encoding);
- scm_misc_error ("scm_i_set_port_encoding_x",
- "invalid or unknown character encoding ~s",
- scm_list_1 (err));
- }
+ scm_display (scm_c_substring (str, start, end), port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
}
-SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
+
+
+
+/* Querying and setting positions, and character availability. */
+
+SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
(SCM port),
- "Returns, as a string, the character encoding that @var{port}\n"
- "uses to interpret its input and output.\n")
-#define FUNC_NAME s_scm_port_encoding
+ "Return @code{#t} if a character is ready on input @var{port}\n"
+ "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
+ "@code{#t} then the next @code{read-char} operation on\n"
+ "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
+ "port at end of file then @code{char-ready?} returns @code{#t}.\n"
+ "\n"
+ "@code{char-ready?} exists to make it possible for a\n"
+ "program to accept characters from interactive ports without\n"
+ "getting stuck waiting for input. Any input editors associated\n"
+ "with such ports must make sure that characters whose existence\n"
+ "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
+ "If @code{char-ready?} were to return @code{#f} at end of file,\n"
+ "a port at end of file would be indistinguishable from an\n"
+ "interactive port that has no ready characters.")
+#define FUNC_NAME s_scm_char_ready_p
{
scm_t_port *pt;
- const char *enc;
- SCM_VALIDATE_PORT (1, port);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ /* It's possible to close the current input port, so validate even in
+ this case. */
+ SCM_VALIDATE_OPINPORT (1, port);
pt = SCM_PTAB_ENTRY (port);
- enc = pt->encoding;
- if (enc)
- return scm_from_locale_string (pt->encoding);
+
+ /* if the current read buffer is filled, or the
+ last pushed-back char has been read and the saved buffer is
+ filled, result is true. */
+ if (pt->read_pos < pt->read_end
+ || (pt->read_buf == pt->putback_buf
+ && pt->saved_read_pos < pt->saved_read_end))
+ return SCM_BOOL_T;
else
- return SCM_BOOL_F;
+ {
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
+
+ if (ptob->input_waiting)
+ return scm_from_bool(ptob->input_waiting (port));
+ else
+ return SCM_BOOL_T;
+ }
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
- (SCM port, SCM enc),
- "Sets the character encoding that will be used to interpret all\n"
- "port I/O. New ports are created with the encoding\n"
- "appropriate for the current locale if @code{setlocale} has \n"
- "been called or ISO-8859-1 otherwise\n"
- "and this procedure can be used to modify that encoding.\n")
-#define FUNC_NAME s_scm_set_port_encoding_x
+SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
+ (SCM fd_port, SCM offset, SCM whence),
+ "Sets the current position of @var{fd/port} to the integer\n"
+ "@var{offset}, which is interpreted according to the value of\n"
+ "@var{whence}.\n"
+ "\n"
+ "One of the following variables should be supplied for\n"
+ "@var{whence}:\n"
+ "@defvar SEEK_SET\n"
+ "Seek from the beginning of the file.\n"
+ "@end defvar\n"
+ "@defvar SEEK_CUR\n"
+ "Seek from the current position.\n"
+ "@end defvar\n"
+ "@defvar SEEK_END\n"
+ "Seek from the end of the file.\n"
+ "@end defvar\n"
+ "If @var{fd/port} is a file descriptor, the underlying system\n"
+ "call is @code{lseek}. @var{port} may be a string port.\n"
+ "\n"
+ "The value returned is the new position in the file. This means\n"
+ "that the current position of a port can be obtained using:\n"
+ "@lisp\n"
+ "(seek port 0 SEEK_CUR)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_seek
{
- char *enc_str;
+ int how;
- SCM_VALIDATE_PORT (1, port);
- SCM_VALIDATE_STRING (2, enc);
+ fd_port = SCM_COERCE_OUTPORT (fd_port);
- enc_str = scm_to_locale_string (enc);
- scm_i_set_port_encoding_x (port, enc_str);
- free (enc_str);
+ how = scm_to_int (whence);
+ if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
+ SCM_OUT_OF_RANGE (3, whence);
- return SCM_UNSPECIFIED;
+ if (SCM_OPPORTP (fd_port))
+ {
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port);
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+
+ if (!ptob->seek)
+ SCM_MISC_ERROR ("port is not seekable",
+ scm_cons (fd_port, SCM_EOL));
+ else
+ rv = ptob->seek (fd_port, off, how);
+ return scm_from_off_t_or_off64_t (rv);
+ }
+ else /* file descriptor?. */
+ {
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+ rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return scm_from_off_t_or_off64_t (rv);
+ }
}
#undef FUNC_NAME
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
-/* This determines how conversions handle unconvertible characters. */
-SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
-static int scm_conversion_strategy_init = 0;
-
-scm_t_string_failed_conversion_handler
-scm_i_get_conversion_strategy (SCM port)
+/* Mingw has ftruncate(), perhaps implemented above using chsize, but
+ doesn't have the filename version truncate(), hence this code. */
+#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
+static int
+truncate (const char *file, off_t length)
{
- SCM encoding;
-
- if (scm_is_false (port))
- {
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- {
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
- if (scm_is_false (encoding))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- return (scm_t_string_failed_conversion_handler) scm_to_int
(encoding);
- }
- }
- else
+ int ret, fdes;
+
+ fdes = open (file, O_BINARY | O_WRONLY);
+ if (fdes == -1)
+ return -1;
+
+ ret = ftruncate (fdes, length);
+ if (ret == -1)
{
- scm_t_port *pt;
- pt = SCM_PTAB_ENTRY (port);
- return pt->ilseq_handler;
+ int save_errno = errno;
+ close (fdes);
+ errno = save_errno;
+ return -1;
}
-
+
+ return close (fdes);
}
+#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
-void
-scm_i_set_conversion_strategy_x (SCM port,
- scm_t_string_failed_conversion_handler handler)
+SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
+ (SCM object, SCM length),
+ "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
+ "filename string, a port object, or an integer file descriptor.\n"
+ "The return value is unspecified.\n"
+ "\n"
+ "For a port or file descriptor @var{length} can be omitted, in\n"
+ "which case the file is truncated at the current position (per\n"
+ "@code{ftell} above).\n"
+ "\n"
+ "On most systems a file can be extended by giving a length\n"
+ "greater than the current size, but this is not mandatory in the\n"
+ "POSIX standard.")
+#define FUNC_NAME s_scm_truncate_file
{
- SCM strategy;
- scm_t_port *pt;
-
- strategy = scm_from_int ((int) handler);
-
- if (scm_is_false (port))
+ int rv;
+
+ /* "object" can be a port, fdes or filename.
+
+ Negative "length" makes no sense, but it's left to truncate() or
+ ftruncate() to give back an error for that (normally EINVAL).
+ */
+
+ if (SCM_UNBNDP (length))
{
- /* Set the default encoding for future ports. */
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- scm_misc_error (NULL, "tried to set conversion strategy fluid before it
is initialized",
- SCM_EOL);
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
+ /* must supply length if object is a filename. */
+ if (scm_is_string (object))
+ SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
+
+ length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
+ }
+
+ object = SCM_COERCE_OUTPORT (object);
+ if (scm_is_integer (object))
+ {
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
+ c_length));
+ }
+ else if (SCM_OPOUTPORTP (object))
+ {
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ scm_t_port *pt = SCM_PTAB_ENTRY (object);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object);
+
+ if (!ptob->truncate)
+ SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (object);
+ else if (pt->rw_active == SCM_PORT_WRITE)
+ ptob->flush (object);
+
+ ptob->truncate (object, c_length);
+ rv = 0;
}
else
{
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
- pt->ilseq_handler = handler;
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ char *str = scm_to_locale_string (object);
+ int eno;
+ SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
+ eno = errno;
+ free (str);
+ errno = eno;
}
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
- 1, 0, 0, (SCM port),
- "Returns the behavior of the port when handling a character that\n"
- "is not representable in the port's current encoding.\n"
- "It returns the symbol @code{error} if unrepresentable characters\n"
- "should cause exceptions, @code{substitute} if the port should\n"
- "try to replace unrepresentable characters with question marks or\n"
- "approximate characters, or @code{escape} if unrepresentable\n"
- "characters should be converted to string escapes.\n"
+SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
+ (SCM port),
+ "Return the current line number for @var{port}.\n"
"\n"
- "If @var{port} is @code{#f}, then the current default behavior\n"
- "will be returned. New ports will have this default behavior\n"
- "when they are created.\n")
-#define FUNC_NAME s_scm_port_conversion_strategy
+ "The first line of a file is 0. But you might want to add 1\n"
+ "when printing line numbers, since starting from 1 is\n"
+ "traditional in error messages, and likely to be more natural to\n"
+ "non-programmers.")
+#define FUNC_NAME s_scm_port_line
{
- scm_t_string_failed_conversion_handler h;
-
- SCM_VALIDATE_OPPORT (1, port);
-
- if (!scm_is_false (port))
- {
- SCM_VALIDATE_OPPORT (1, port);
- }
-
- h = scm_i_get_conversion_strategy (port);
- if (h == SCM_FAILED_CONVERSION_ERROR)
- return scm_from_latin1_symbol ("error");
- else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
- return scm_from_latin1_symbol ("substitute");
- else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
- return scm_from_latin1_symbol ("escape");
- else
- abort ();
-
- /* Never gets here. */
- return SCM_UNDEFINED;
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_long (SCM_LINUM (port));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_conversion_strategy_x,
"set-port-conversion-strategy!",
- 2, 0, 0,
- (SCM port, SCM sym),
- "Sets the behavior of the interpreter when outputting a character\n"
- "that is not representable in the port's current encoding.\n"
- "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
- "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
- "when an unconvertible character is encountered. If it is\n"
- "@code{'substitute}, then unconvertible characters will \n"
- "be replaced with approximate characters, or with question marks\n"
- "if no approximately correct character is available.\n"
- "If it is @code{'escape},\n"
- "it will appear as a hex escape when output.\n"
- "\n"
- "If @var{port} is an open port, the conversion error behavior\n"
- "is set for that port. If it is @code{#f}, it is set as the\n"
- "default behavior for any future ports that get created in\n"
- "this thread.\n")
-#define FUNC_NAME s_scm_set_port_conversion_strategy_x
+SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
+ (SCM port, SCM line),
+ "Set the current line number for @var{port} to @var{line}. The\n"
+ "first line of a file is 0.")
+#define FUNC_NAME s_scm_set_port_line_x
{
- SCM err;
- SCM qm;
- SCM esc;
-
- if (!scm_is_false (port))
- {
- SCM_VALIDATE_OPPORT (1, port);
- }
-
- err = scm_from_latin1_symbol ("error");
- if (scm_is_true (scm_eqv_p (sym, err)))
- {
- scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
- return SCM_UNSPECIFIED;
- }
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- qm = scm_from_latin1_symbol ("substitute");
- if (scm_is_true (scm_eqv_p (sym, qm)))
- {
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_QUESTION_MARK);
- return SCM_UNSPECIFIED;
- }
+SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
+ (SCM port),
+ "Return the current column number of @var{port}.\n"
+ "If the number is\n"
+ "unknown, the result is #f. Otherwise, the result is a 0-origin
integer\n"
+ "- i.e. the first character of the first line is line 0, column
0.\n"
+ "(However, when you display a file position, for example in an
error\n"
+ "message, we recommend you add 1 to get 1-origin integers. This
is\n"
+ "because lines and column numbers traditionally start with 1, and
that is\n"
+ "what non-programmers will find most natural.)")
+#define FUNC_NAME s_scm_port_column
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_int (SCM_COL (port));
+}
+#undef FUNC_NAME
- esc = scm_from_latin1_symbol ("escape");
- if (scm_is_true (scm_eqv_p (sym, esc)))
- {
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
- return SCM_UNSPECIFIED;
- }
+SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
+ (SCM port, SCM column),
+ "Set the current column of @var{port}. Before reading the first\n"
+ "character on a line the column should be 0.")
+#define FUNC_NAME s_scm_set_port_column_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
+SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
+ (SCM port),
+ "Return the filename associated with @var{port}, or @code{#f}\n"
+ "if no filename is associated with the port.")
+#define FUNC_NAME s_scm_port_filename
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return SCM_FILENAME (port);
+}
+#undef FUNC_NAME
+SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
+ (SCM port, SCM filename),
+ "Change the filename associated with @var{port}, using the current
input\n"
+ "port if none is specified. Note that this does not change the
port's\n"
+ "source of data, but only the value that is returned by\n"
+ "@code{port-filename} and reported in diagnostic output.")
+#define FUNC_NAME s_scm_set_port_filename_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ /* We allow the user to set the filename to whatever he likes. */
+ SCM_SET_FILENAME (port, filename);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+
+
+/* Implementation helpers for port printing functions. */
void
scm_print_port_mode (SCM exp, SCM port)
{
- scm_puts (SCM_CLOSEDP (exp)
+ scm_puts_unlocked (SCM_CLOSEDP (exp)
? "closed: "
: (SCM_RDNG & SCM_CELL_WORD_0 (exp)
? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
@@ -2463,15 +2577,91 @@ scm_port_print (SCM exp, SCM port, scm_print_state
*pstate SCM_UNUSED)
char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
if (!type)
type = "port";
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
scm_print_port_mode (exp, port);
- scm_puts (type, port);
- scm_putc (' ', port);
+ scm_puts_unlocked (type, port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
+
+
+
+/* Iterating over all ports. */
+
+struct for_each_data
+{
+ void (*proc) (void *data, SCM p);
+ void *data;
+};
+
+static SCM
+for_each_trampoline (void *data, SCM port, SCM result)
+{
+ struct for_each_data *d = data;
+
+ d->proc (d->data, port);
+
+ return result;
+}
+
+void
+scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+{
+ struct for_each_data d;
+
+ d.proc = proc;
+ d.data = data;
+
+ scm_c_weak_set_fold (for_each_trampoline, &d, SCM_EOL,
+ scm_i_port_weak_set);
+}
+
+static void
+scm_for_each_trampoline (void *data, SCM port)
+{
+ scm_call_1 (SCM_PACK_POINTER (data), port);
+}
+
+SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
+ (SCM proc),
+ "Apply @var{proc} to each port in the Guile port table\n"
+ "in turn. The return value is unspecified. More specifically,\n"
+ "@var{proc} is applied exactly once to every port that exists\n"
+ "in the system at the time @var{port-for-each} is invoked.\n"
+ "Changes to the port table while @var{port-for-each} is running\n"
+ "have no effect as far as @var{port-for-each} is concerned.")
+#define FUNC_NAME s_scm_port_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_c_port_for_each (scm_for_each_trampoline, SCM_UNPACK_POINTER (proc));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+flush_output_port (void *closure, SCM port)
+{
+ if (SCM_OPOUTPORTP (port))
+ scm_flush_unlocked (port);
+}
+
+SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
+ (),
+ "Equivalent to calling @code{force-output} on\n"
+ "all open output ports. The return value is unspecified.")
+#define FUNC_NAME s_scm_flush_all_ports
+{
+ scm_c_port_for_each (&flush_output_port, NULL);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
/* Void ports. */
@@ -2520,7 +2710,9 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1,
0, 0,
}
#undef FUNC_NAME
+
+
/* Initialization. */
void
diff --git a/libguile/ports.h b/libguile/ports.h
index 2b72a70..56cafdb 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -294,44 +294,59 @@ SCM_API SCM scm_port_conversion_strategy (SCM port);
SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
/* Acquiring and releasing the port lock. */
-SCM_INLINE int scm_c_lock_port (scm_t_port *entry);
-SCM_INLINE int scm_c_try_lock_port (scm_t_port *entry);
-SCM_INLINE int scm_c_unlock_port (scm_t_port *entry);
+SCM_INLINE int scm_c_lock_port (SCM port);
+SCM_INLINE int scm_c_try_lock_port (SCM port);
+SCM_INLINE int scm_c_unlock_port (SCM port);
-/* Meta. */
+/* Revealed counts. */
SCM_API int scm_revealed_count (SCM port);
SCM_API SCM scm_port_revealed (SCM port);
SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
+SCM_API SCM scm_adjust_port_revealed_x (SCM port, SCM addend);
/* Input. */
-SCM_INLINE int scm_get_byte_or_eof (SCM port);
-SCM_INLINE int scm_peek_byte_or_eof (SCM port);
+SCM_API int scm_get_byte_or_eof (SCM port);
+SCM_INLINE int scm_get_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_peek_byte_or_eof (SCM port);
+SCM_INLINE int scm_peek_byte_or_eof_unlocked (SCM port);
SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
+SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size);
SCM_API scm_t_wchar scm_getc (SCM port);
-SCM_API SCM scm_peek_char (SCM port);
+SCM_API scm_t_wchar scm_getc_unlocked (SCM port);
SCM_API SCM scm_read_char (SCM port);
/* Pushback. */
SCM_INTERNAL void scm_unget_byte (int c, SCM port);
+SCM_INTERNAL void scm_unget_byte_unlocked (int c, SCM port);
SCM_API void scm_ungetc (scm_t_wchar c, SCM port);
+SCM_API void scm_ungetc_unlocked (scm_t_wchar c, SCM port);
SCM_API void scm_ungets (const char *s, int n, SCM port);
+SCM_API void scm_ungets_unlocked (const char *s, int n, SCM port);
+SCM_API SCM scm_peek_char (SCM port);
SCM_API SCM scm_unread_char (SCM cobj, SCM port);
SCM_API SCM scm_unread_string (SCM str, SCM port);
/* Manipulating the buffers. */
SCM_API void scm_port_non_buffer (scm_t_port *pt);
SCM_API int scm_fill_input (SCM port);
+SCM_API int scm_fill_input_unlocked (SCM port);
SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t
read_len);
SCM_API SCM scm_drain_input (SCM port);
SCM_API void scm_end_input (SCM port);
+SCM_API void scm_end_input_unlocked (SCM port);
SCM_API SCM scm_force_output (SCM port);
SCM_API void scm_flush (SCM port);
+SCM_API void scm_flush_unlocked (SCM port);
/* Output. */
-SCM_INLINE void scm_putc (char c, SCM port);
-SCM_INLINE void scm_puts (const char *str_data, SCM port);
+SCM_API void scm_putc (char c, SCM port);
+SCM_INLINE void scm_putc_unlocked (char c, SCM port);
+SCM_API void scm_puts (const char *str_data, SCM port);
+SCM_INLINE void scm_puts_unlocked (const char *str_data, SCM port);
SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
+SCM_API void scm_c_write_unlocked (SCM port, const void *buffer, size_t size);
SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
+SCM_API void scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port);
SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
SCM port);
@@ -367,37 +382,37 @@ SCM_INTERNAL void scm_init_ports (void);
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
SCM_INLINE_IMPLEMENTATION int
-scm_c_lock_port (scm_t_port *entry)
+scm_c_lock_port (SCM port)
{
#if SCM_USE_PTHREAD_THREADS
- return scm_i_pthread_mutex_lock (&entry->lock);
+ return scm_i_pthread_mutex_lock (&SCM_PTAB_ENTRY (port)->lock);
#else
return 0;
#endif
}
SCM_INLINE_IMPLEMENTATION int
-scm_c_try_lock_port (scm_t_port *entry)
+scm_c_try_lock_port (SCM port)
{
#if SCM_USE_PTHREAD_THREADS
- return scm_i_pthread_mutex_trylock (&entry->lock);
+ return scm_i_pthread_mutex_trylock (&SCM_PTAB_ENTRY (port)->lock);
#else
return 0;
#endif
}
SCM_INLINE_IMPLEMENTATION int
-scm_c_unlock_port (scm_t_port *entry)
+scm_c_unlock_port (SCM port)
{
#if SCM_USE_PTHREAD_THREADS
- return scm_i_pthread_mutex_unlock (&entry->lock);
+ return scm_i_pthread_mutex_unlock (&SCM_PTAB_ENTRY (port)->lock);
#else
return 0;
#endif
}
SCM_INLINE_IMPLEMENTATION int
-scm_get_byte_or_eof (SCM port)
+scm_get_byte_or_eof_unlocked (SCM port)
{
int c;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -411,7 +426,7 @@ scm_get_byte_or_eof (SCM port)
if (pt->read_pos >= pt->read_end)
{
- if (SCM_UNLIKELY (scm_fill_input (port) == EOF))
+ if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
return EOF;
}
@@ -422,7 +437,7 @@ scm_get_byte_or_eof (SCM port)
/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
SCM_INLINE_IMPLEMENTATION int
-scm_peek_byte_or_eof (SCM port)
+scm_peek_byte_or_eof_unlocked (SCM port)
{
int c;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -436,7 +451,7 @@ scm_peek_byte_or_eof (SCM port)
if (pt->read_pos >= pt->read_end)
{
- if (SCM_UNLIKELY (scm_fill_input (port) == EOF))
+ if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
return EOF;
}
@@ -446,17 +461,17 @@ scm_peek_byte_or_eof (SCM port)
}
SCM_INLINE_IMPLEMENTATION void
-scm_putc (char c, SCM port)
+scm_putc_unlocked (char c, SCM port)
{
SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
- scm_lfwrite (&c, 1, port);
+ scm_lfwrite_unlocked (&c, 1, port);
}
SCM_INLINE_IMPLEMENTATION void
-scm_puts (const char *s, SCM port)
+scm_puts_unlocked (const char *s, SCM port)
{
SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
- scm_lfwrite (s, strlen (s), port);
+ scm_lfwrite_unlocked (s, strlen (s), port);
}
#endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */
diff --git a/libguile/print.c b/libguile/print.c
index 5ee48ee..62cf2a1 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -156,7 +156,7 @@ do
\
{ \
if (pstate->top - pstate->list_offset >= pstate->level) \
{ \
- scm_putc ('#', port); \
+ scm_putc_unlocked ('#', port);
\
return; \
} \
} \
@@ -300,9 +300,9 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref)
for (i = pstate->top - 1; 1; --i)
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
break;
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_intprint (i - self, 10, port);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
}
/* Print the name of a symbol. */
@@ -393,7 +393,7 @@ print_extended_symbol (SCM sym, SCM port)
len = scm_i_symbol_length (sym);
strategy = scm_i_get_conversion_strategy (port);
- scm_lfwrite ("#{", 2, port);
+ scm_lfwrite_unlocked ("#{", 2, port);
for (pos = 0; pos < len; pos++)
{
@@ -416,7 +416,7 @@ print_extended_symbol (SCM sym, SCM port)
}
}
- scm_lfwrite ("}#", 2, port);
+ scm_lfwrite_unlocked ("}#", 2, port);
}
/* FIXME: allow R6RS hex escapes instead of #{...}#. */
@@ -452,7 +452,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state
*pstate);
scm_intprint (i, 8, port); \
else \
{ \
- scm_puts ("x", port); \
+ scm_puts_unlocked ("x", port); \
scm_intprint (i, 16, port); \
} \
} \
@@ -507,7 +507,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
else if (SCM_IFLAGP (exp)
&& ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof
(char *))))
{
- scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
+ scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port);
}
else
{
@@ -601,11 +601,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
else
{
- scm_puts ("#<uninterned-symbol ", port);
+ scm_puts_unlocked ("#<uninterned-symbol ", port);
scm_i_print_symbol_name (exp, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
break;
case scm_tc7_variable:
@@ -652,7 +652,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
- scm_puts ("#w(", port);
+ scm_puts_unlocked ("#w(", port);
goto common_vector_printer;
case scm_tc7_bytevector:
@@ -660,7 +660,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
break;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
- scm_puts ("#(", port);
+ scm_puts_unlocked ("#(", port);
common_vector_printer:
{
register long i;
@@ -675,7 +675,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
for (i = 0; i < last; ++i)
{
scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
if (i == last)
{
@@ -683,8 +683,8 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
}
if (cutp)
- scm_puts (" ...", port);
- scm_putc (')', port);
+ scm_puts_unlocked (" ...", port);
+ scm_putc_unlocked (')', port);
}
EXIT_NESTED_DATA (pstate);
break;
@@ -836,7 +836,7 @@ display_string_as_utf8 (const void *str, int narrow_p,
size_t len,
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (utf8_buf, utf8_len, port);
+ scm_lfwrite_unlocked (utf8_buf, utf8_len, port);
printed += i - printed;
}
@@ -897,7 +897,7 @@ display_string_using_iconv (const void *str, int narrow_p,
size_t len,
iconv (pt->output_cd, NULL, NULL, NULL, NULL);
/* Print the OUTPUT_LEN bytes successfully converted. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
/* See how many input codepoints these OUTPUT_LEN bytes
corresponds to. */
@@ -932,7 +932,7 @@ display_string_using_iconv (const void *str, int narrow_p,
size_t len,
{
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
codepoints_read = i - printed;
printed += codepoints_read;
}
@@ -1012,7 +1012,7 @@ write_character_escaped (scm_t_wchar ch, int
string_escapes_p, SCM port)
/* Use special escapes for some C0 controls. */
buf[0] = '\\';
buf[1] = escapes[ch - 0x07];
- scm_lfwrite (buf, 2, port);
+ scm_lfwrite_unlocked (buf, 2, port);
}
else if (!SCM_R6RS_ESCAPES_P)
{
@@ -1022,7 +1022,7 @@ write_character_escaped (scm_t_wchar ch, int
string_escapes_p, SCM port)
buf[1] = 'x';
buf[2] = hex[ch / 16];
buf[3] = hex[ch % 16];
- scm_lfwrite (buf, 4, port);
+ scm_lfwrite_unlocked (buf, 4, port);
}
else if (ch <= 0xFFFF)
{
@@ -1032,7 +1032,7 @@ write_character_escaped (scm_t_wchar ch, int
string_escapes_p, SCM port)
buf[3] = hex[(ch & 0xF00) >> 8];
buf[4] = hex[(ch & 0xF0) >> 4];
buf[5] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 6, port);
+ scm_lfwrite_unlocked (buf, 6, port);
}
else if (ch > 0xFFFF)
{
@@ -1044,7 +1044,7 @@ write_character_escaped (scm_t_wchar ch, int
string_escapes_p, SCM port)
buf[5] = hex[(ch & 0xF00) >> 8];
buf[6] = hex[(ch & 0xF0) >> 4];
buf[7] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 8, port);
+ scm_lfwrite_unlocked (buf, 8, port);
}
}
else
@@ -1067,7 +1067,7 @@ write_character_escaped (scm_t_wchar ch, int
string_escapes_p, SCM port)
buf[i] = 'x';
i --;
buf[i] = '\\';
- scm_lfwrite (buf + i, 9 - i, port);
+ scm_lfwrite_unlocked (buf + i, 9 - i, port);
}
}
else
@@ -1077,7 +1077,7 @@ write_character_escaped (scm_t_wchar ch, int
string_escapes_p, SCM port)
name = scm_i_charname (SCM_MAKE_CHAR (ch));
if (name != NULL)
- scm_puts (name, port);
+ scm_puts_unlocked (name, port);
else
PRINT_CHAR_ESCAPE (ch, port);
}
@@ -1142,14 +1142,14 @@ void
scm_intprint (scm_t_intmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port);
}
void
scm_uintprint (scm_t_uintmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port);
}
/* Print an object of unrecognized type.
@@ -1158,19 +1158,19 @@ scm_uintprint (scm_t_uintmax n, int radix, SCM port)
void
scm_ipruk (char *hdr, SCM ptr, SCM port)
{
- scm_puts ("#<unknown-", port);
- scm_puts (hdr, port);
+ scm_puts_unlocked ("#<unknown-", port);
+ scm_puts_unlocked (hdr, port);
if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
{
- scm_puts (" (0x", port);
+ scm_puts_unlocked (" (0x", port);
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
- scm_puts (" . 0x", port);
+ scm_puts_unlocked (" . 0x", port);
scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
- scm_puts (") @", port);
+ scm_puts_unlocked (") @", port);
}
- scm_puts (" 0x", port);
+ scm_puts_unlocked (" 0x", port);
scm_uintprint (SCM_UNPACK (ptr), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
@@ -1181,7 +1181,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port,
scm_print_state *pstate)
{
register SCM hare, tortoise;
long floor = pstate->top - 2;
- scm_puts (hdr, port);
+ scm_puts_unlocked (hdr, port);
/* CHECK_INTS; */
if (pstate->fancyp)
goto fancy_printing;
@@ -1211,18 +1211,18 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port,
scm_print_state *pstate)
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
goto circref;
PUSH_REF (pstate, exp);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
end:
- scm_putc (tlr, port);
+ scm_putc_unlocked (tlr, port);
pstate->top = floor + 2;
return;
@@ -1243,7 +1243,7 @@ fancy_printing:
{
if (n == 0)
{
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
goto skip_tail;
}
else
@@ -1251,14 +1251,14 @@ fancy_printing:
}
PUSH_REF(pstate, exp);
++pstate->list_offset;
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
skip_tail:
@@ -1269,7 +1269,7 @@ fancy_circref:
pstate->list_offset -= pstate->top - floor - 2;
circref:
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
print_circref (port, pstate, exp);
goto end;
}
@@ -1422,7 +1422,7 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
SCM_VALIDATE_OPORT_VALUE (1, port);
- scm_putc ('\n', SCM_COERCE_OUTPORT (port));
+ scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/programs.c b/libguile/programs.c
index b84f84b..128e031 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -82,22 +82,22 @@ scm_i_program_print (SCM program, SCM port, scm_print_state
*pstate)
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
/* twingliness */
- scm_puts ("#<continuation ", port);
+ scm_puts_unlocked ("#<continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
{
/* twingliness */
- scm_puts ("#<partial-continuation ", port);
+ scm_puts_unlocked ("#<partial-continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else if (scm_is_false (write_program) || print_error)
{
- scm_puts ("#<program ", port);
+ scm_puts_unlocked ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else
{
diff --git a/libguile/promises.c b/libguile/promises.c
index 4aff150..57a2081 100644
--- a/libguile/promises.c
+++ b/libguile/promises.c
@@ -88,11 +88,11 @@ static int
promise_print (SCM exp, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<promise ", port);
+ scm_puts_unlocked ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 06576e9..60ba38c 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -475,7 +475,7 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0,
0,
if (SCM_LIKELY (c_count > 0))
/* XXX: `scm_c_read ()' does not update the port position. */
- c_read = scm_c_read (port, c_bv, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv, c_count);
else
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
@@ -522,7 +522,7 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4,
0, 0,
scm_out_of_range (FUNC_NAME, count);
if (SCM_LIKELY (c_count > 0))
- c_read = scm_c_read (port, c_bv + c_start, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv + c_start, c_count);
else
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
@@ -577,7 +577,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some",
1, 0, 0,
}
/* We can't use `scm_c_read ()' since it blocks. */
- c_chr = scm_getc (port);
+ c_chr = scm_getc_unlocked (port);
if (c_chr != EOF)
{
c_bv[c_total] = (char) c_chr;
@@ -642,7 +642,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all",
1, 0, 0,
/* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
reached. */
- c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count);
c_total += c_read, c_count -= c_read;
}
while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
@@ -688,7 +688,7 @@ SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
c_octet = scm_to_uint8 (octet);
- scm_putc ((char) c_octet, port);
+ scm_putc_unlocked ((char) c_octet, port);
return SCM_UNSPECIFIED;
}
@@ -731,7 +731,7 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
else
c_start = 0, c_count = c_len;
- scm_c_write (port, c_bv + c_start, c_count);
+ scm_c_write_unlocked (port, c_bv + c_start, c_count);
return SCM_UNSPECIFIED;
}
@@ -1094,7 +1094,7 @@ make_tp (SCM binary_port, unsigned long mode)
static void
tp_write (SCM port, const void *data, size_t size)
{
- scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
+ scm_c_write_unlocked (SCM_TP_BINARY_PORT (port), data, size);
}
static int
@@ -1112,7 +1112,7 @@ tp_fill_input (SCM port)
scm_force_output (bport);
if (c_bport->read_pos >= c_bport->read_end)
- scm_fill_input (bport);
+ scm_fill_input_unlocked (bport);
count = c_bport->read_end - c_bport->read_pos;
if (count > c_port->read_buf_size)
@@ -1149,7 +1149,7 @@ tp_flush (SCM port)
We just throw away the data when the underlying port is closed. */
if (SCM_OPOUTPORTP (binary_port))
- scm_c_write (binary_port, c_port->write_buf, count);
+ scm_c_write_unlocked (binary_port, c_port->write_buf, count);
c_port->write_pos = c_port->write_buf;
c_port->rw_active = SCM_PORT_NEITHER;
@@ -1231,7 +1231,7 @@ SCM_DEFINE (scm_get_string_n_x,
for (j = c_start; j < c_end; j++)
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
{
size_t chars_read = j - c_start;
diff --git a/libguile/rdelim.c b/libguile/rdelim.c
index 9d14967..c8c7d8b 100644
--- a/libguile/rdelim.c
+++ b/libguile/rdelim.c
@@ -79,13 +79,13 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3,
0,
{
size_t k;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
for (k = 0; k < num_delims; k++)
{
if (scm_i_string_ref (delims, k) == c)
{
if (scm_is_false (gobble))
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_cons (SCM_MAKE_CHAR (c),
scm_from_size_t (j - cstart));
@@ -149,7 +149,7 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
}
else
{
- buf[index] = scm_getc (port);
+ buf[index] = scm_getc_unlocked (port);
switch (buf[index])
{
case EOF:
diff --git a/libguile/read.c b/libguile/read.c
index 4b9c248..97f7702 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -216,13 +216,13 @@ read_token (SCM port, char *buf, const size_t buf_size,
size_t *read)
{
int chr;
- chr = scm_get_byte_or_eof (port);
+ chr = scm_get_byte_or_eof_unlocked (port);
if (chr == EOF)
return 0;
else if (CHAR_IS_DELIMITER (chr))
{
- scm_unget_byte (chr, port);
+ scm_unget_byte_unlocked (chr, port);
return 0;
}
else
@@ -288,7 +288,7 @@ flush_ws (SCM port, const char *eoferr)
{
register scm_t_wchar c;
while (1)
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goteof:
@@ -303,7 +303,7 @@ flush_ws (SCM port, const char *eoferr)
case ';':
lp:
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto goteof;
@@ -315,7 +315,7 @@ flush_ws (SCM port, const char *eoferr)
break;
case '#':
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
eoferr = "read_sharp";
@@ -334,7 +334,7 @@ flush_ws (SCM port, const char *eoferr)
}
/* fall through */
default:
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return '#';
}
break;
@@ -375,7 +375,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
if (terminating_char == c)
return SCM_EOL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
tmp = scm_read_expression (port);
/* Note that it is possible for scm_read_expression to return
@@ -402,7 +402,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
"in pair: mismatched close paren: ~A",
scm_list_1 (SCM_MAKE_CHAR (c)));
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
tmp = scm_read_expression (port);
/* See above note about scm_sym_dot. */
@@ -442,7 +442,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
c = 0; \
while (i < ndigits) \
{ \
- a = scm_getc (port); \
+ a = scm_getc_unlocked (port); \
if (a == EOF) \
goto str_eof; \
if (terminator \
@@ -472,13 +472,13 @@ skip_intraline_whitespace (SCM port)
do
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
return;
}
while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR));
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
}
static SCM
@@ -493,7 +493,7 @@ scm_read_string (int chr, SCM port)
scm_t_wchar c;
str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
- while ('"' != (c = scm_getc (port)))
+ while ('"' != (c = scm_getc_unlocked (port)))
{
if (c == EOF)
{
@@ -511,7 +511,7 @@ scm_read_string (int chr, SCM port)
if (c == '\\')
{
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto str_eof;
@@ -596,7 +596,7 @@ scm_read_number (scm_t_wchar chr, SCM port)
int overflow;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
overflow = read_complete_token (port, buffer, sizeof (buffer),
&overflow_buffer, &bytes_read);
@@ -633,7 +633,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
overflow = read_complete_token (port, buffer, READER_BUFFER_SIZE,
&overflow_buffer, &bytes_read);
if (bytes_read > 0)
@@ -710,8 +710,8 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
break;
default:
- scm_ungetc (chr, port);
- scm_ungetc ('#', port);
+ scm_ungetc_unlocked (chr, port);
+ scm_ungetc_unlocked ('#', port);
radix = 10;
}
@@ -762,12 +762,12 @@ scm_read_quote (int chr, SCM port)
{
scm_t_wchar c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if ('@' == c)
p = scm_sym_uq_splicing;
else
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
p = scm_sym_unquote;
}
break;
@@ -812,12 +812,12 @@ scm_read_syntax (int chr, SCM port)
{
int c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if ('@' == c)
p = sym_unsyntax_splicing;
else
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
p = sym_unsyntax;
}
break;
@@ -857,9 +857,9 @@ scm_read_semicolon_comment (int chr, SCM port)
/* We use the get_byte here because there is no need to get the
locale correct with comment input. This presumes that newline
always represents itself no matter what the encoding is. */
- for (c = scm_get_byte_or_eof (port);
+ for (c = scm_get_byte_or_eof_unlocked (port);
(c != EOF) && (c != '\n');
- c = scm_get_byte_or_eof (port));
+ c = scm_get_byte_or_eof_unlocked (port));
return SCM_UNSPECIFIED;
}
@@ -901,7 +901,7 @@ scm_read_character (scm_t_wchar chr, SCM port)
if (bytes_read == 0)
{
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr == EOF)
scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
"while reading character", SCM_EOL);
@@ -1028,15 +1028,15 @@ scm_read_srfi4_vector (int chr, SCM port)
static SCM
scm_read_bytevector (scm_t_wchar chr, SCM port)
{
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != 'u')
goto syntax;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != '8')
goto syntax;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != '(')
goto syntax;
@@ -1056,15 +1056,15 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
terribly inefficient but who cares? */
SCM s_bits = SCM_EOL;
- for (chr = scm_getc (port);
+ for (chr = scm_getc_unlocked (port);
(chr != EOF) && ((chr == '0') || (chr == '1'));
- chr = scm_getc (port))
+ chr = scm_getc_unlocked (port))
{
s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
}
if (chr != EOF)
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
}
@@ -1076,7 +1076,7 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
for (;;)
{
- int c = scm_getc (port);
+ int c = scm_getc_unlocked (port);
if (c == EOF)
scm_i_input_error ("skip_block_comment", port,
@@ -1097,30 +1097,30 @@ static SCM
scm_read_shebang (scm_t_wchar chr, SCM port)
{
int c = 0;
- if ((c = scm_get_byte_or_eof (port)) != 'r')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != '6')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != '6')
{
- scm_ungetc (c, port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != 'r')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
{
- scm_ungetc (c, port);
- scm_ungetc ('6', port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('6', port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != 's')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 's')
{
- scm_ungetc (c, port);
- scm_ungetc ('r', port);
- scm_ungetc ('6', port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('r', port);
+ scm_ungetc_unlocked ('6', port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
@@ -1134,7 +1134,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
nested. So care must be taken. */
int nesting_level = 1;
- int a = scm_getc (port);
+ int a = scm_getc_unlocked (port);
if (a == EOF)
scm_i_input_error ("scm_read_r6rs_block_comment", port,
@@ -1142,7 +1142,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
while (nesting_level > 0)
{
- int b = scm_getc (port);
+ int b = scm_getc_unlocked (port);
if (b == EOF)
scm_i_input_error ("scm_read_r6rs_block_comment", port,
@@ -1174,7 +1174,7 @@ scm_read_commented_expression (scm_t_wchar chr, SCM port)
if (EOF == c)
scm_i_input_error ("read_commented_expression", port,
"no expression after #; comment", SCM_EOL);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
scm_read_expression (port);
return SCM_UNSPECIFIED;
}
@@ -1193,7 +1193,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port)
buf = scm_i_string_start_writing (buf);
- while ((chr = scm_getc (port)) != EOF)
+ while ((chr = scm_getc_unlocked (port)) != EOF)
{
if (saw_brace)
{
@@ -1220,7 +1220,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port)
that the extended read syntax would never put a `\' before
an `x'. For now, we just ignore other instances of
backslash in the string. */
- switch ((chr = scm_getc (port)))
+ switch ((chr = scm_getc_unlocked (port)))
{
case EOF:
goto done;
@@ -1307,7 +1307,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
{
SCM result;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
result = scm_read_sharp_extension (chr, port);
if (!scm_is_eq (result, SCM_UNSPECIFIED))
@@ -1398,7 +1398,7 @@ scm_read_expression (SCM port)
{
register scm_t_wchar chr;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
switch (chr)
{
@@ -1476,7 +1476,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0,
c = flush_ws (port, (char *) NULL);
if (EOF == c)
return SCM_EOF_VAL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return (scm_read_expression (port));
}
@@ -1588,7 +1588,7 @@ scm_i_scan_for_encoding (SCM port)
pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
@@ -1596,7 +1596,7 @@ scm_i_scan_for_encoding (SCM port)
if (pt->read_pos == pt->read_end)
{
/* We can use the read buffer, and thus avoid a seek. */
- if (scm_fill_input (port) == EOF)
+ if (scm_fill_input_unlocked (port) == EOF)
return NULL;
bytes_read = pt->read_end - pt->read_pos;
@@ -1621,7 +1621,7 @@ scm_i_scan_for_encoding (SCM port)
if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
return NULL;
- bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+ bytes_read = scm_c_read_unlocked (port, header,
SCM_ENCODING_SEARCH_SIZE);
header[bytes_read] = '\0';
scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
}
diff --git a/libguile/rw.c b/libguile/rw.c
index a9b4a32..677e0d8 100644
--- a/libguile/rw.c
+++ b/libguile/rw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -248,7 +248,7 @@ SCM_DEFINE (scm_write_string_partial,
"write-string/partial", 1, 3, 0,
return scm_from_long (write_len);
}
if (pt->write_pos > pt->write_buf)
- scm_flush (port);
+ scm_flush_unlocked (port);
fdes = SCM_FPORT_FDES (port);
}
{
diff --git a/libguile/smob.c b/libguile/smob.c
index 02ad1a5..cb6f803 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -108,14 +108,14 @@ int
scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
long n = SCM_SMOBNUM (exp);
- scm_puts ("#<", port);
- scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
+ scm_putc_unlocked (' ', port);
if (scm_smobs[n].size)
scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
else
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 9f07498..f63f1bc 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -95,11 +95,11 @@ static int
srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<srcprops ", port);
+ scm_puts_unlocked ("#<srcprops ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c
index e2f6668..0932370 100644
--- a/libguile/srfi-14.c
+++ b/libguile/srfi-14.c
@@ -597,27 +597,27 @@ charset_print (SCM charset, SCM port, scm_print_state
*pstate SCM_UNUSED)
p = SCM_CHARSET_DATA (charset);
- scm_puts ("#<charset {", port);
+ scm_puts_unlocked ("#<charset {", port);
for (i = 0; i < p->len; i++)
{
if (first)
first = 0;
else
- scm_puts (" ", port);
+ scm_puts_unlocked (" ", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
if (p->ranges[i].lo != p->ranges[i].hi)
{
- scm_puts ("..", port);
+ scm_puts_unlocked ("..", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
}
if (i >= max_ranges_to_print)
{
/* Too many to print here. Quit early. */
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
break;
}
}
- scm_puts ("}>", port);
+ scm_puts_unlocked ("}>", port);
return 1;
}
@@ -630,16 +630,16 @@ charset_cursor_print (SCM cursor, SCM port,
cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- scm_puts ("#<charset-cursor ", port);
+ scm_puts_unlocked ("#<charset-cursor ", port);
if (cur->range == (size_t) (-1))
- scm_puts ("(empty)", port);
+ scm_puts_unlocked ("(empty)", port);
else
{
scm_write (scm_from_size_t (cur->range), port);
- scm_puts (":", port);
+ scm_puts_unlocked (":", port);
scm_write (scm_from_int32 (cur->n), port);
}
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
diff --git a/libguile/stackchk.c b/libguile/stackchk.c
index 7b9b4c4..208ba97 100644
--- a/libguile/stackchk.c
+++ b/libguile/stackchk.c
@@ -86,11 +86,11 @@ scm_stack_report ()
scm_uintprint ((scm_stack_size (thread->continuation_base)
* sizeof (SCM_STACKITEM)),
16, port);
- scm_puts (" of stack: 0x", port);
+ scm_puts_unlocked (" of stack: 0x", port);
scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
- scm_puts (" - 0x", port);
+ scm_puts_unlocked (" - 0x", port);
scm_uintprint ((scm_t_bits) &stack, 16, port);
- scm_puts ("\n", port);
+ scm_puts_unlocked ("\n", port);
}
diff --git a/libguile/strports.c b/libguile/strports.c
index 2b3a5ea..fc52a86 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -207,7 +207,7 @@ st_seek (SCM port, scm_t_off offset, int whence)
st_flush (port);
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ scm_end_input_unlocked (port);
switch (whence)
{
diff --git a/libguile/struct.c b/libguile/struct.c
index cb046a1..8b21330 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -981,22 +981,22 @@ scm_print_struct (SCM exp, SCM port, scm_print_state
*pstate)
{
SCM vtable = SCM_STRUCT_VTABLE (exp);
SCM name = scm_struct_vtable_name (vtable);
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
if (scm_is_true (name))
{
scm_display (name, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
else
{
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
- scm_puts ("vtable:", port);
+ scm_puts_unlocked ("vtable:", port);
else
- scm_puts ("struct:", port);
+ scm_puts_unlocked ("struct:", port);
scm_uintprint (SCM_UNPACK (vtable), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (SCM_VTABLE_LAYOUT (vtable), port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
scm_uintprint (SCM_UNPACK (exp), 16, port);
/* hackety hack */
@@ -1004,19 +1004,19 @@ scm_print_struct (SCM exp, SCM port, scm_print_state
*pstate)
{
if (scm_is_true (SCM_STRUCT_PROCEDURE (exp)))
{
- scm_puts (" proc: ", port);
+ scm_puts_unlocked (" proc: ", port);
if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp))))
scm_write (SCM_STRUCT_PROCEDURE (exp), port);
else
- scm_puts ("(not a procedure?)", port);
+ scm_puts_unlocked ("(not a procedure?)", port);
}
if (SCM_STRUCT_SETTER_P (exp))
{
- scm_puts (" setter: ", port);
+ scm_puts_unlocked (" setter: ", port);
scm_write (SCM_STRUCT_SETTER (exp), port);
}
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
}
diff --git a/libguile/threads.c b/libguile/threads.c
index 2560b69..ec5001f 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -367,11 +367,11 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
else
id = u.um;
- scm_puts ("#<thread ", port);
+ scm_puts_unlocked ("#<thread ", port);
scm_uintprint (id, 10, port);
- scm_puts (" (", port);
+ scm_puts_unlocked (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
- scm_puts (")>", port);
+ scm_puts_unlocked (")>", port);
return 1;
}
@@ -1270,9 +1270,9 @@ static int
fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
{
fat_mutex *m = SCM_MUTEX_DATA (mx);
- scm_puts ("#<mutex ", port);
+ scm_puts_unlocked ("#<mutex ", port);
scm_uintprint ((scm_t_bits)m, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
@@ -1727,9 +1727,9 @@ static int
fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
fat_cond *c = SCM_CONDVAR_DATA (cv);
- scm_puts ("#<condition-variable ", port);
+ scm_puts_unlocked ("#<condition-variable ", port);
scm_uintprint ((scm_t_bits)c, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
diff --git a/libguile/throw.c b/libguile/throw.c
index e3b5afa..29ccc8a 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -370,7 +370,7 @@ handler_message (void *handler_data, SCM tag, SCM args)
if (should_print_backtrace (tag, stack))
{
- scm_puts ("Backtrace:\n", p);
+ scm_puts_unlocked ("Backtrace:\n", p);
scm_display_backtrace_with_highlights (stack, p,
SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL);
diff --git a/libguile/values.c b/libguile/values.c
index ab77731..005be50 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -60,9 +60,9 @@ print_values (SCM obj, SCM pwps)
SCM port = SCM_PORT_WITH_PS_PORT (pwps);
scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));
- scm_puts ("#<values ", port);
+ scm_puts_unlocked ("#<values ", port);
scm_iprin1 (values, port, ps);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return SCM_UNSPECIFIED;
}
diff --git a/libguile/variable.c b/libguile/variable.c
index a9cc60e..7b3f335 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -36,11 +36,11 @@
void
scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<variable ", port);
+ scm_puts_unlocked ("#<variable ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_puts (" value: ", port);
+ scm_puts_unlocked (" value: ", port);
scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 9958e11..9b8e93a 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -83,9 +83,9 @@ static SCM sym_debug;
void
scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<vm-continuation ", port);
+ scm_puts_unlocked ("#<vm-continuation ", port);
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
/* In theory, a number of vm instances can be active in the call trace, and we
@@ -351,22 +351,22 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
vm = SCM_VM_DATA (x);
- scm_puts ("#<vm ", port);
+ scm_puts_unlocked ("#<vm ", port);
switch (vm->engine)
{
case SCM_VM_REGULAR_ENGINE:
- scm_puts ("regular-engine ", port);
+ scm_puts_unlocked ("regular-engine ", port);
break;
case SCM_VM_DEBUG_ENGINE:
- scm_puts ("debug-engine ", port);
+ scm_puts_unlocked ("debug-engine ", port);
break;
default:
- scm_puts ("unknown-engine ", port);
+ scm_puts_unlocked ("unknown-engine ", port);
}
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
static SCM
diff --git a/libguile/vports.c b/libguile/vports.c
index 05d4590..62f552a 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -114,7 +114,7 @@ sf_fill_input (SCM port)
return *pt->read_buf;
}
else
- scm_ungetc (SCM_CHAR (ans), port);
+ scm_ungetc_unlocked (SCM_CHAR (ans), port);
return SCM_CHAR (ans);
}
diff --git a/libguile/weak-set.c b/libguile/weak-set.c
index 626b290..53d22a3 100644
--- a/libguile/weak-set.c
+++ b/libguile/weak-set.c
@@ -619,12 +619,12 @@ make_weak_set (unsigned long k)
void
scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<", port);
- scm_puts ("weak-set ", port);
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked ("weak-set ", port);
scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port);
- scm_putc ('/', port);
+ scm_putc_unlocked ('/', port);
scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
static void
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
index 3ec113a..18e1648 100644
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@@ -719,12 +719,12 @@ make_weak_table (unsigned long k, scm_t_weak_table_kind
kind)
void
scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<", port);
- scm_puts ("weak-table ", port);
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked ("weak-table ", port);
scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port);
- scm_putc ('/', port);
+ scm_putc_unlocked ('/', port);
scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
static void
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-117-gf209aee,
Andy Wingo <=