summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/ChangeLog331
-rw-r--r--libguile/Makefile.am36
-rw-r--r--libguile/_scm.h5
-rw-r--r--libguile/continuations.c36
-rw-r--r--libguile/continuations.h2
-rw-r--r--libguile/coop-pthreads.c4
-rw-r--r--libguile/environments.c7
-rw-r--r--libguile/eval.c43
-rw-r--r--libguile/filesys.c44
-rw-r--r--libguile/fports.c89
-rw-r--r--libguile/fports.h3
-rw-r--r--libguile/gc.c72
-rw-r--r--libguile/gc.h9
-rw-r--r--libguile/gen-scmconfig.c4
-rw-r--r--libguile/gen-scmconfig.h.in1
-rw-r--r--libguile/gettext.c331
-rw-r--r--libguile/gettext.h110
-rw-r--r--libguile/i18n.c1234
-rw-r--r--libguile/i18n.h27
-rw-r--r--libguile/init.c10
-rw-r--r--libguile/libgettext.h69
-rw-r--r--libguile/locale-categories.h47
-rw-r--r--libguile/modules.c5
-rw-r--r--libguile/numbers.c165
-rw-r--r--libguile/numbers.h4
-rw-r--r--libguile/ports.c74
-rw-r--r--libguile/posix.c59
-rw-r--r--libguile/posix.h5
-rw-r--r--libguile/pthread-threads.h6
-rw-r--r--libguile/script.c4
-rw-r--r--libguile/socket.c58
-rw-r--r--libguile/stime.c18
-rw-r--r--libguile/threads.c14
-rw-r--r--libguile/unif.c14
-rw-r--r--libguile/vectors.c12
35 files changed, 2450 insertions, 502 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 4b7b805f8..8ba446c6c 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,4 +1,195 @@
-2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES
+ instead of RES (reported by Gyula Szavai). This allows the use of
+ negative lower bounds.
+ (scm_i_read_array): Make sure LEN is non-negative (reported by
+ Gyula Szavai).
+
+ (scm_array_in_bounds_p): Iterate over S instead of always
+ comparing indices with the bounds of S[0]. This fixes
+ `array-in-bounds?' for arrays with a rank greater than one and
+ with different lower bounds for each dimension.
+
+2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * libguile/vectors.c (scm_vector_to_list): Fixed list
+ construction: elements were not copied when INC is zero (see
+ "shared array" example in `vectors.test'). Reported by
+ Szavai Gyula.
+
+2006-11-18 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * Makefile.am (lib_LTLIBRARIES): Added `libguile-i18n-v-XX.la'.
+ (libguile_la_SOURCES): Added `gettext.c', removed `i18n.c'.
+ (libguile_i18n_v_XX_la_SOURCES, libguile_i18n_v_XX_la_CFLAGS,
+ libguile_i18n_v_XX_la_LIBADD, libguile_i18n_v_XX_la_LDFLAGS): New.
+ (DOT_X_FILES): Added `gettext.x'.
+ (DOT_DOC_FILES): Likewise.
+ (EXTRA_libguile_la_SOURCES): Added `locale-categories.h'.
+ (modinclude_HEADERS): Added `gettext.h'.
+ (EXTRA_DIST): Added `libgettext.h'.
+
+ * gettext.h: Renamed to...
+ * libgettext.h: New file.
+
+ * i18n.c: Renamed to...
+ * gettext.c: New file.
+
+ * i18n.h: Renamed to...
+ * gettext.h: New file.
+
+ * i18n.c, i18n.h, locale-categories.h: New files.
+
+ * init.c: Include "libguile/gettext.h" instead of
+ "libguile/i18n.h".
+ (scm_i_init_guile): Invoke `scm_init_gettext ()' instead of
+ `scm_init_i18n ()'.
+
+ * posix.c: Include "libguile/gettext.h" instead of
+ "libguile/i18n.h" Test `HAVE_NEWLOCALE' and `HAVE_STRCOLL_L'.
+ (USE_GNU_LOCALE_API): New macro.
+ (scm_i_locale_mutex): New variable.
+ (scm_setlocale): Lock and unlock it around `setlocale ()' calls.
+
+ * posix.h: Include "libguile/threads.h".
+ (scm_i_locale_mutex): New declaration.
+
+2006-11-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ * script.c (scm_shell_usage): Note need for subscription to bug-guile@gnu.org.
+
+2006-11-08 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * libguile/gc-freelist.c (scm_i_adjust_min_yield): Take two
+ "sweep_stats" arguments; use them instead of accessing the global
+ variables `scm_gc_cells_collected' and `scm_gc_cells_collected_1'.
+
+ * libguile/gc-segment.c (scm_i_sweep_some_cards): Reset SWEEP
+ before each iteration of the loop.
+ (scm_i_sweep_some_segments): Reset SWEEP at each iteration.
+ (scm_i_get_new_heap_segment): Take an additional argument
+ SWEEP_STATS. Compute MIN_CELLS as a function of it.
+
+ * libguile/gc.c (scm_gc_cells_collected,
+ scm_gc_cells_collected_1): Removed.
+ (scm_i_gc_sweep_stats, scm_i_gc_sweep_stats_1): New.
+ (scm_gc_cells_marked_acc, scm_gc_cells_swept_acc,
+ scm_gc_time_taken, scm_gc_mark_time_taken, scm_gc_times,
+ scm_gc_cell_yield_percentage, protected_obj_count): Made `static'.
+ (scm_gc_stats): Use `scm_i_gc_sweep_stats' instead of
+ `scm_gc_cells_(collected|swept)'.
+ (gc_update_stats): New.
+ (gc_end_stats): Use `scm_i_gc_sweep_stats' and
+ `scm_i_gc_sweep_stats_1' instead of the former globals.
+ (scm_gc_for_newcell): Invoke `gc_update_stats ()' after each
+ `scm_i_sweep_some_segments' call. This fixes a bug where the GC
+ would keep allocating new segments instead of re-using collected
+ cells (because `scm_gc_cells_collected' would remain zero).
+
+ * libguile/gc.h (scm_gc_cells_swept, scm_gc_cells_collected,
+ scm_gc_cell_yield_percentage): Removed.
+
+ * libguile/private-gc.h (scm_gc_cells_collected_1): Removed.
+ (scm_i_adjust_min_yield): Updated.
+ (scm_i_get_new_heap_segment): Updated.
+
+2006-11-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * modules.c: Correct comment saying that low-level environments
+ will be used "in the next release".
+
+ * init.c: Comment out #include of environments.h.
+ (scm_i_init_guile): Comment out scm_environments_prehistory() and
+ scm_init_environments() calls.
+
+ * Makefile.am (libguile_la_SOURCES): Remove environments.c.
+ (DOT_X_FILES): Remove environments.x.
+ (DOT_DOC_FILES): Remove environments.doc.
+ (modinclude_HEADERS): Remove environments.h.
+
+2006-10-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ IA64 HP-UX GC patch from Hrvoje Nikšić. (Thanks!)
+
+ * threads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() and
+ scm_ia64_register_backing_store_base() instead of Linux-specific
+ implementations.
+
+ * gc.h (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp):
+ New declarations.
+
+ * gc.c (__libc_ia64_register_backing_store_base): Declaration
+ removed.
+ (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): New, with
+ implementations for Linux and HP-UX.
+
+ * coop-pthreads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp()
+ and scm_ia64_register_backing_store_base() instead of
+ Linux-specific implementations.
+
+ * continuations.h (__libc_ia64_register_backing_store_base):
+ Declaration removed.
+ (scm_t_contregs): New "fresh" field.
+
+ * continuations.c (ia64_getcontext): Removed.
+ (scm_make_continuation): Use continuation fresh field instead of
+ interpreting getcontext return values (which isn't portable). Use
+ scm_ia64_ar_bsp() and scm_ia64_register_backing_store_base()
+ instead of Linux-specific implementations.
+ (copy_stack_and_call): Use scm_ia64_register_backing_store_base()
+ instead of Linux-specific implementation.
+
+ * _scm.h (__ia64__): Also detect __ia64.
+
+2006-10-03 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c (SCM_APPLY): For scm_tc7_subr_2o, throw wrong-num-args on 0
+ arguments or 3 or more arguments. Previously 0 called proc with
+ SCM_UNDEFINED, and 3 or more silently used just the first 2.
+
+2006-09-28 Kevin Ryde <user42@zip.com.au>
+
+ * fports.c, ports.c (ftruncate): Use "HAVE_CHSIZE && ! HAVE_FTRUNCATE"
+ for chsize fallback, instead of hard-coding mingw. Mingw in fact
+ supplies ftruncate itself these days.
+
+ * ports.c (fcntl.h): Can include this unconditionally, no need for
+ __MINGW32__.
+
+ * ports.c (truncate): Conditionalize on "HAVE_FTRUNCATE && !
+ HAVE_TRUNCATE" so as not to hard-code mingw. Use "const char *" and
+ "off_t" for parameters, per usual definition of this function, rather
+ than "char *" and "int". Use ftruncate instead of chsize. Check for
+ error on final close.
+
+2006-09-27 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_log10): Check HAVE_CLOG10, clog10() is not available
+ in mingw.
+
+ * posix.c (scm_execl, scm_execlp, scm_execle): Cast "const char *
+ const *" for mingw to suppress warnings from gcc (which are errors
+ under the configure default -Werror). Reported by Nils Durner.
+
+2006-09-26 Kevin Ryde <user42@zip.com.au>
+
+ * _scm.h (scm_to_off64_t, scm_from_off64_t): New macros.
+ * fports.c (scm_open_file): Use open_or_open64.
+ (fport_seek_or_seek64): New function, adapting fport_seek.
+ * fports.c, fports.h (scm_i_fport_seek, scm_i_fport_truncate): New
+ functions.
+ * ports.c (scm_seek, scm_truncate_file): Use scm_i_fport_seek and
+ scm_i_fport_truncate to allow 64-bit seeks and truncates on fports.
+
+ * ports.c (scm_truncate_file): Update docstring per manual.
+
+2006-09-23 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c, numbers.h (scm_log, scm_log10, scm_exp, scm_sqrt): New
+ functions.
+
+2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
* srfi-14.c: Include <config.h>. Define `_GNU_SOURCE'.
(make_predset, define_predset, make_strset, define_strset, false,
@@ -20,6 +211,11 @@
(scm_setlocale): Invoke `scm_srfi_14_compute_char_sets ()' after a
successful `setlocale ()' call.
+2006-09-08 Kevin Ryde <user42@zip.com.au>
+
+ * socket.c (scm_init_socket): Add MSG_DONTWAIT.
+ (scm_recvfrom): Update docstring from manual.
+
2006-08-31 Rob Browning <rlb@defaultvalue.org>
* ports.c (scm_c_port_for_each): Add a
@@ -32,11 +228,47 @@
improvements to docstring.
(scm_backtrace_with_highlights): Analogous improvements.
+2006-08-12 Kevin Ryde <user42@zip.com.au>
+
+ * gen-scmconfig.h.in (SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT):
+ New, set from configure.
+ * gen-scmconfig.c (SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT): New output
+ to scmconfig.h.
+ * pthread-threads.h (SCM_I_PTHREAD_ONCE_INIT): Use
+ SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT to cope with Solaris.
+ Reported by Claes Wallin.
+
2006-08-11 Neil Jerram <neil@ossau.uklinux.net>
* stacks.c (scm_last_stack_frame): Correct docstring (returns a
frame, not a stack).
+2006-07-25 Kevin Ryde <user42@zip.com.au>
+
+ * threads.c (get_thread_stack_base): Restrict HAVE_PTHREAD_GETATTR_NP
+ on pthreads version, since pthread_getattr_np not available on solaris
+ and macos. Reported by Claes Wallin.
+
+2006-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c (dirfd): Test with #ifndef rather than HAVE_DIRFD, since
+ it's a macro on MacOS X. Reported by Claes Wallin.
+
+ * posix.c (sethostname): Give prototype if not HAVE_DECL_SETHOSTNAME,
+ for the benefit of Solaris 10. Reported by Claes Wallin.
+
+ * socket.c (scm_htonl, scm_ntohl): Use scm_to_uint32 rather than
+ NUM2ULONG, to enforce 32-bit range check on systems with 64-bit long.
+
+2006-07-21 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c, filesys.c (alloca): Update <alloca.h> etc blob, per current
+ autoconf recommendation. Should fix Solaris 10 reported by Claes
+ Wallin.
+
+ * threads.c: Include <string.h>, needed for memset() which is used by
+ FD_ZERO() on Solaris 10. Reported by Claes Wallin.
+
2006-07-18 Rob Browning <rlb@defaultvalue.org>
* continuations.c: Add __attribute__ ((returns_twice)) to the
@@ -44,12 +276,31 @@
arrangements and avoid an illegal instruction during
call-with-current-continuation.
-2006-07-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-07-12 Ludovic Courtès <ludovic.courtes@laas.fr>
* numbers.c (guile_ieee_init): Use regular ANSI C casts rather
than C++-style `X_CAST ()'. Patch posted by by Mike Gran.
-2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-07-08 Kevin Ryde <user42@zip.com.au>
+
+ * environments.c (core_environments_unobserve): Use if/else rather
+ than ?: for "SET" bits, avoiding complaints from AIX xlc compiler
+ about them not being rvalues. Reported by Mike Gran.
+
+ * Makefile.am (version.h): Don't use $< in an explicit rule, it's not
+ portable and in particular fails on OpenBSD and AIX (see autoconf
+ manual too). Reported by Mike Gran.
+
+2006-06-25 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c (bdtime2c): tm_gmtoff is seconds East, so take negative of
+ tm:gmtoff which is seconds West. Reported by Aaron VanDevender.
+ (bdtime2c): Test HAVE_STRUCT_TM_TM_GMTOFF for tm_gmtoff, rather than
+ HAVE_TM_ZONE.
+ (scm_strptime): Use tm_gmtoff from the strptime result when that field
+ exists, it's set by glibc strptime "%s".
+
+2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
* eq.c: Include "struct.h", "goops.h" and "objects.h".
(scm_equal_p): Invoke `scm_i_struct_equalp ()' on structures that
@@ -187,7 +438,7 @@
2006-04-06 Kevin Ryde <user42@zip.com.au>
* fports.c (scm_setvbuf): Fix for not _IOLBF, clear SCM_BUFLINE
- instead of toggling it. Reported by Ludovic Courtès.
+ instead of toggling it. Reported by Ludovic Courtès.
2006-03-26 Marius Vollmer <mvo@zagadka.de>
@@ -199,7 +450,7 @@
* gc_os_dep.c (scm_get_stack_base): Abort when the machine type is
unknown instead of returning NULL.
-2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr>
* numbers.c (scm_i_mem2number): Renamed to
scm_c_locale_stringn_to_number.
@@ -291,7 +542,7 @@
(scm_i_sweep_statistics_init): New macro.
(scm_i_sweep_statistics_sum): New macro
-2006-02-14 Ludovic Courtès <ludovic.courtes@laas.fr>
+2006-02-14 Ludovic Courtès <ludovic.courtes@laas.fr>
* strings.c (scm_i_take_stringbufn): Register LEN+1 bytes instead of
LEN. Without this, too much collectable memory gets unregistered,
@@ -409,7 +660,7 @@
* inline.h, pairs.c (scm_is_pair): Moved scm_is_pair from pairs.c
to inline.h to make it inline.
-2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr>
+2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr>
* strings.c (scm_i_take_stringbufn): New.
(scm_i_c_take_symbol): New.
@@ -442,7 +693,7 @@
2005-12-29 Neil Jerram <neil@ossau.uklinux.net>
- * fluids.c (next_fluid_num): [From Ludovic Courtès:] Don't trigger
+ * fluids.c (next_fluid_num): [From Ludovic Courtès:] Don't trigger
the GC when allocated_fluids_len is zero.
2005-12-14 Neil Jerram <neil@ossau.uklinux.net>
@@ -474,7 +725,7 @@
* srfi-4.h, srfi-4.c, srfi-4.i.c (take_uvec): Make BASE pointer
non-const.
- (scm_take_u8vector, etc): Likewise. Thanks to Ludovic Courtès!
+ (scm_take_u8vector, etc): Likewise. Thanks to Ludovic Courtès!
* threads.h, threads.c (scm_t_guile_ticket, scm_leave_guile,
scm_enter_guile): Removed from public API. See comment at
@@ -489,7 +740,7 @@
* eval.c (scm_m_cond): Recognize SRFI 61 cond syntax.
(CEVAL): Evaluate SRFI 61 cond clauses.
-2005-12-06 Ludovic Courtès <ludovic.courtes@laas.fr>
+2005-12-06 Ludovic Courtès <ludovic.courtes@laas.fr>
* gc-card.c (scm_i_card_statistics): Return if BITVEC is NULL.
This was typically hit when running `gc-live-object-stats' right
@@ -503,7 +754,7 @@
2005-11-26 Kevin Ryde <user42@zip.com.au>
* gc-mark.c (scm_mark_all): Change C++ comment to C comment. Reported
- by Ludovic Courtès.
+ by Ludovic Courtès.
* list.c (list): Should be "primitive" in SCM_SNARF_DOCS, not
"register".
@@ -515,7 +766,7 @@
* socket.c (scm_fill_sockaddr): Remove SCM_C_INLINE_KEYWORD, this is
much too big to want to inline.
-2005-11-17 Ludovic Courtès <ludovic.courtes@laas.fr>
+2005-11-17 Ludovic Courtès <ludovic.courtes@laas.fr>
* print.c (EXIT_NESTED_DATA): Before popping from the stack, reset
the value at its top. This fixes a reference leak.
@@ -523,14 +774,14 @@
`PSTATE_STACK_SET ()' in order to avoid undesired potential side
effects.
-2005-11-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+2005-11-12 Ludovic Courtès <ludovic.courtes@laas.fr>
* gc.c (scm_weak_vectors): Removed.
2005-11-12 Kevin Ryde <user42@zip.com.au>
* socket.c (scm_setsockopt): Missing @defvar in docstring. Reported
- by Ludovic Courtès.
+ by Ludovic Courtès.
2005-11-07 Marius Vollmer <mvo@zagadka.de>
@@ -552,7 +803,7 @@
* debug.h (SCM_CHEAPTRAPS_P): Removed.
-2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr>
+2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr>
* socket.c (scm_fill_sockaddr): No need to check NULL from scm_malloc.
(scm_connect, scm_bind, scm_sendto): Accept sockaddr object.
@@ -860,7 +1111,7 @@
2005-05-11 Neil Jerram <neil@ossau.uklinux.net>
- Fix C99isms reported by Ludovic Courtès:
+ Fix C99isms reported by Ludovic Courtès:
* threads.c (s_scm_lock_mutex): Don't declare msg in middle of
code.
@@ -975,7 +1226,7 @@
2005-03-18 Kevin Ryde <user42@zip.com.au>
* arbiters.c (FETCH_STORE) [generic C]: Should be
- scm_i_scm_pthread_mutex_lock/unlock now. Reported by Ludovic Courtès.
+ scm_i_scm_pthread_mutex_lock/unlock now. Reported by Ludovic Courtès.
2005-03-13 Kevin Ryde <user42@zip.com.au>
@@ -2121,7 +2372,7 @@
2004-11-02 Marius Vollmer <mvo@zagadka.de>
- Mac OS X and OpenBSD compatibility patches from Andreas Vögele.
+ Mac OS X and OpenBSD compatibility patches from Andreas Vögele.
Thanks!
* backtrace.c (scm_display_backtrace_with_highlights): Join the
@@ -2565,7 +2816,7 @@
* numbers.h, numbers.c: Include <gmp.h> in numbers.h, not in
numbers.c.
(scm_to_mpz, scm_from_mpz): New.
- Thanks to Andreas Vögele!
+ Thanks to Andreas Vögele!
* read.c (skip_scsh_block_comment): Recognize "!#" everywhere, not
just on a line of its own.
@@ -2574,7 +2825,7 @@
scm_string_tabulate, string_upcase_x, string_down_case_x,
string_titlecase_x, string_reverse_x, scm_string_tokenize): Use
size_t instead of int for indices into strings. Make sure that no
- over- or underflow occurs. Thanks to Andreas Vögele!
+ over- or underflow occurs. Thanks to Andreas Vögele!
(scm_xsubstring, scm_string_xcopy_x): Use ints for 'extended'
indices, which can also be negative.
@@ -2596,7 +2847,7 @@
* filesys.c, stime.c (_POSIX_C_SOURCE): Use this only on hpux, it
causes too many problems elsewhere (glibc, freebsd, mingw). Reported
- by Andreas Vögele.
+ by Andreas Vögele.
2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
@@ -3431,7 +3682,7 @@
* gc_os_dep.c: update ifdefery for macosx.
(scm_get_stack_base): separate result initialization from
declaration to slience warnings with macosx and hp-ux using gcc
- 3.3. Thanks to Andreas Vögele.
+ 3.3. Thanks to Andreas Vögele.
2004-06-13 Han-Wen Nienhuys <hanwen@xs4all.nl>
@@ -3641,10 +3892,10 @@
2004-05-02 Kevin Ryde <user42@zip.com.au>
* eval.c (scm_macroexp): Add prototype, since it's not in eval.h under
- --disable-deprecated. Reported by Andreas Vögele.
+ --disable-deprecated. Reported by Andreas Vögele.
* filesys.c (_POSIX_C_SOURCE): Define to 199506L to get readdir_r (in
- particular on HP-UX). Reported by Andreas Vögele.
+ particular on HP-UX). Reported by Andreas Vögele.
* list.c (varargs.h): Remove, leave just stdarg.h which is all the
code has support for. Fixes building with AIX cc, which is ansi but
@@ -3655,14 +3906,14 @@
2004-05-01 Kevin Ryde <user42@zip.com.au>
* continuations.c (scm_dynthrow): Use >= instead of SCM_PTR_GE which
- is now gone. Reported by Andreas Vögele.
+ is now gone. Reported by Andreas Vögele.
2004-04-28 Kevin Ryde <user42@zip.com.au>
* backtrace.c (display_frame_expr), numbers.c (XDIGIT2UINT,
mem2uinteger, mem2decimal_from_point, mem2ureal): Cast char to int for
ctype.h tests, to avoid warnings from gcc on HP-UX about char as array
- subscript. Reported by Andreas Vögele.
+ subscript. Reported by Andreas Vögele.
Also cast through unsigned char to avoid passing negatives to those
macros if input contains 8-bit values.
@@ -3676,17 +3927,17 @@
* numbers.c (scm_bit_extract): Use min instead of MIN.
(MIN): Remove, this conflicts with similar macro defined by limits.h
- on HP-UX. Reported by Andreas Vögele.
+ on HP-UX. Reported by Andreas Vögele.
* stime.c (_POSIX_C_SOURCE): Define to 199506L to get gmtime_r (in
- particular on HP-UX). Reported by Andreas Vögele.
+ particular on HP-UX). Reported by Andreas Vögele.
* threads.c (scm_threads_mark_stacks): Correction sizet -> size_t.
- Reported by Andreas Vögele.
+ Reported by Andreas Vögele.
* threads-plugin.h (SCM_MUTEX_MAXSIZE): Increase to 25*sizeof(long),
for the benefit of hpux11 where pthread_mutex_t is 88 bytes. Reported
- by Andreas Vögele.
+ by Andreas Vögele.
2004-04-22 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
@@ -7539,7 +7790,7 @@
2002-08-26 Marius Vollmer <mvo@zagadka.ping.de>
* script.c (scm_compile_shell_switches): Added "2002" to Copyright
- years. Thanks to Martin Grabmüller!
+ years. Thanks to Martin Grabmüller!
2002-08-25 Han-Wen Nienhuys <hanwen@cs.uu.nl>
@@ -9455,7 +9706,7 @@
* deprecation.c (scm_include_deprecated_features): Simplified.
* eval.c (EVALCAR, unmemocopy), eval.h (SCM_XEVALCAR): Use
- `SCM_IMP' instead of `!SCM_CELLP´.
+ `SCM_IMP' instead of `!SCM_CELLP´.
* eval.c (unmemocopy): Eliminate redundant SCM_CELLP tests.
Extract side-effecting operations from macros.
@@ -10496,7 +10747,7 @@
2001-06-09 Marius Vollmer <mvo@zagadka.ping.de>
* ports.c (scm_lfwrite): Maintain columnd and row count in port.
- Thanks to Matthias Köppe!
+ Thanks to Matthias Köppe!
2001-06-08 Michael Livshin <mlivshin@bigfoot.com>
@@ -10504,7 +10755,7 @@
space-happy C preprocessors.
* filter-doc-snarfage.c, guile-snarf.in: try to cope with spaces
- inside cookies. thanks to Matthias Köppe!
+ inside cookies. thanks to Matthias Köppe!
2001-06-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
@@ -11079,7 +11330,7 @@
SCM_VARIABLE_INIT since that it what it used to be.
* deprecation.c (scm_include_deprecated_features): Make docstring
- ANSIsh. Thanks to Matthias Köppe!
+ ANSIsh. Thanks to Matthias Köppe!
2001-05-21 Marius Vollmer <mvo@zagadka.ping.de>
@@ -11433,7 +11684,7 @@
2001-05-15 Marius Vollmer <mvo@zagadka.ping.de>
* values.c (print_values): Print as a unreadable object, not as
- multiple lines. Thanks to Matthias Köppe!
+ multiple lines. Thanks to Matthias Köppe!
2001-05-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
@@ -11465,7 +11716,7 @@
2001-05-09 Michael Livshin <mlivshin@bigfoot.com>
- from Matthias Köppe (thanks!):
+ from Matthias Köppe (thanks!):
* ports.c (scm_c_read): pointer arithmetic on void pointers isn't
portable.
@@ -13322,7 +13573,7 @@
2001-01-11 Michael Livshin <mlivshin@bigfoot.com>
- from Matthias Köppe:
+ from Matthias Köppe:
* objects.h (SCM_SET_ENTITY_SETTER): new macro. SCM_ENTITY_SETTER
casts its result, so doesn't yield an lvalue per ANSI C.
@@ -13391,3 +13642,7 @@
(write_all): new helper procedure.
The ChangeLog continues in the file: "ChangeLog-2000"
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 34b747324..6e1fa8634 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -31,7 +31,8 @@ INCLUDES = -I.. -I$(top_srcdir)
ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
-lib_LTLIBRARIES = libguile.la
+lib_LTLIBRARIES = libguile.la \
+ libguile-i18n-v-@LIBGUILE_I18N_MAJOR@.la
bin_PROGRAMS = guile
noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig
@@ -94,12 +95,12 @@ libguile_la_CFLAGS = $(GUILE_CFLAGS)
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
chars.c continuations.c convert.c debug.c deprecation.c \
- deprecated.c discouraged.c dynwind.c environments.c eq.c error.c \
+ deprecated.c discouraged.c dynwind.c eq.c error.c \
eval.c evalext.c extensions.c feature.c fluids.c fports.c \
futures.c gc.c gc-malloc.c \
- gdbint.c gh_data.c gh_eval.c gh_funcs.c \
+ gdbint.c gettext.c gh_data.c gh_eval.c gh_funcs.c \
gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \
- guardians.c hash.c hashtab.c hooks.c i18n.c init.c inline.c \
+ guardians.c hash.c hashtab.c hooks.c init.c inline.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
print.c procprop.c procs.c properties.c random.c rdelim.c read.c \
@@ -109,11 +110,20 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
ramap.c unif.c
+libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
+libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
+ $(libguile_la_CFLAGS)
+libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \
+ libguile.la
+libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
+ -module -L$(builddir) -lguile \
+ -version-info @LIBGUILE_I18N_INTERFACE@
+
DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
continuations.x debug.x deprecation.x deprecated.x discouraged.x \
dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \
extensions.x feature.x fluids.x fports.x futures.x gc.x \
- goops.x gsubr.x guardians.x \
+ gettext.c goops.x gsubr.x guardians.x \
hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
@@ -128,10 +138,10 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \
deprecated.doc discouraged.doc dynl.doc dynwind.doc \
- environments.doc eq.doc error.doc eval.doc evalext.doc \
+ eq.doc error.doc eval.doc evalext.doc \
extensions.doc feature.doc fluids.doc fports.doc futures.doc \
gc.doc goops.doc gsubr.doc \
- gc-malloc.doc guardians.doc hash.doc hashtab.doc \
+ gc-malloc.doc gettext.doc guardians.doc hash.doc hashtab.doc \
hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
@@ -154,7 +164,8 @@ EXTRA_libguile_la_SOURCES = _scm.h \
dynl.c regex-posix.c \
filesys.c posix.c net_db.c socket.c \
debug-malloc.c mkstemp.c \
- win32-uname.c win32-dirent.c win32-socket.c
+ win32-uname.c win32-dirent.c win32-socket.c \
+ locale-categories.h
## delete guile-snarf.awk from the installation bindir, in case it's
## lingering there due to an earlier guile version not having been
@@ -186,9 +197,10 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
boehm-gc.h \
boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \
deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \
- environments.h eq.h error.h eval.h evalext.h extensions.h \
+ eq.h error.h eval.h evalext.h extensions.h \
feature.h filesys.h fluids.h fports.h futures.h gc.h \
- gdb_interface.h gdbint.h goops.h gsubr.h guardians.h hash.h \
+ gdb_interface.h gdbint.h gettext.h goops.h \
+ gsubr.h guardians.h hash.h \
hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \
keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \
net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \
@@ -213,7 +225,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \
cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \
cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \
c-tokenize.lex version.h.in \
- scmconfig.h.top gettext.h
+ scmconfig.h.top libgettext.h
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi
@@ -221,7 +233,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \
## usual @...@, so autoconf doesn't go and substitute the values
## directly into the left-hand sides of the sed substitutions. *sigh*
version.h: version.h.in
- sed < $< > $@.tmp \
+ sed < $(srcdir)/version.h.in > $@.tmp \
-e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \
-e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \
-e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}:
diff --git a/libguile/_scm.h b/libguile/_scm.h
index ea654ad39..fd05770c2 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -54,6 +54,9 @@
and differences between _scm.h and __scm.h.
**********************************************************************/
+#if defined(__ia64) && !defined(__ia64__)
+# define __ia64__
+#endif
#if HAVE_CONFIG_H
# include <config.h>
@@ -167,6 +170,8 @@
#else
# error sizeof(off_t) is not 4 or 8.
#endif
+#define scm_to_off64_t scm_to_int64
+#define scm_from_off64_t scm_from_int64
#endif /* SCM__SCM_H */
diff --git a/libguile/continuations.c b/libguile/continuations.c
index f9e52df2a..a06ae79ab 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -57,22 +57,6 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
return 1;
}
-#ifdef __ia64__
-/* Extern declaration of getcontext()/setcontext() in order to redefine
- getcontext() since on ia64-linux the second return value indicates whether
- it returned from getcontext() itself or by running setcontext(). */
-struct rv
-{
- long retval;
- long first_return;
-};
-
-#ifdef __GNUC__
-__attribute__ ((returns_twice))
-#endif /* __GNUC__ */
-extern struct rv ia64_getcontext (ucontext_t *) __asm__ ("getcontext");
-#endif /* __ia64__ */
-
/* this may return more than once: the first time with the escape
procedure, then subsequently with the value to be passed to the
continuation. */
@@ -85,9 +69,6 @@ scm_make_continuation (int *first)
scm_t_contregs *continuation;
long stack_size;
SCM_STACKITEM * src;
-#ifdef __ia64__
- struct rv rv;
-#endif /* __ia64__ */
SCM_FLUSH_REGISTER_WINDOWS;
stack_size = scm_stack_size (thread->continuation_base);
@@ -109,20 +90,23 @@ scm_make_continuation (int *first)
memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
#ifdef __ia64__
- rv = ia64_getcontext (&continuation->ctx);
- if (rv.first_return)
+ continuation->fresh = 1;
+ getcontext (&continuation->ctx);
+ if (continuation->fresh)
{
- continuation->backing_store_size =
- continuation->ctx.uc_mcontext.sc_ar_bsp -
- (unsigned long) __libc_ia64_register_backing_store_base;
+ continuation->backing_store_size =
+ (char *) scm_ia64_ar_bsp(&continuation->ctx)
+ -
+ (char *) scm_ia64_register_backing_store_base ();
continuation->backing_store = NULL;
continuation->backing_store =
scm_gc_malloc (continuation->backing_store_size,
"continuation backing store");
memcpy (continuation->backing_store,
- (void *) __libc_ia64_register_backing_store_base,
+ (void *) scm_ia64_register_backing_store_base (),
continuation->backing_store_size);
*first = 1;
+ continuation->fresh = 0;
return cont;
}
else
@@ -217,7 +201,7 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
continuation->throw_value = val;
#ifdef __ia64__
- memcpy ((void *) __libc_ia64_register_backing_store_base,
+ memcpy (scm_ia64_register_backing_store_base (),
continuation->backing_store,
continuation->backing_store_size);
setcontext (&continuation->ctx);
diff --git a/libguile/continuations.h b/libguile/continuations.h
index d10297956..0274c1b2d 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -27,7 +27,6 @@
#ifdef __ia64__
#include <signal.h>
#include <ucontext.h>
-extern unsigned long * __libc_ia64_register_backing_store_base;
#endif /* __ia64__ */
@@ -48,6 +47,7 @@ typedef struct
SCM dynenv;
#ifdef __ia64__
ucontext_t ctx;
+ int fresh;
void *backing_store;
unsigned long backing_store_size;
#endif /* __ia64__ */
diff --git a/libguile/coop-pthreads.c b/libguile/coop-pthreads.c
index 2ca8b4f6f..641583037 100644
--- a/libguile/coop-pthreads.c
+++ b/libguile/coop-pthreads.c
@@ -827,8 +827,8 @@ scm_threads_init (SCM_STACKITEM *base)
scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
/ sizeof (SCM_STACKITEM))); \
- bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
- top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
+ bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \
+ top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
scm_mark_locations (bot, top - bot); } while (0)
#else
# define SCM_MARK_BACKING_STORE()
diff --git a/libguile/environments.c b/libguile/environments.c
index 34788cc74..ed23d3011 100644
--- a/libguile/environments.c
+++ b/libguile/environments.c
@@ -667,9 +667,10 @@ core_environments_unobserve (SCM env, SCM observer)
if (scm_is_eq (first, observer))
{
/* Remove the first observer */
- handling_weaks
- ? SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest)
- : SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
+ if (handling_weaks)
+ SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
+ else
+ SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
return;
}
diff --git a/libguile/eval.c b/libguile/eval.c
index ae4ee4fd8..dcbd1ac7d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -37,24 +37,22 @@
#ifndef DEVAL
-/* AIX requires this to be the first thing in the file. The #pragma
- directive is indented so pre-ANSI compilers will ignore it, rather
- than choke on it. */
-#ifndef __GNUC__
-# if HAVE_ALLOCA_H
-# include <alloca.h>
-# else
-# ifdef _AIX
-# pragma alloca
-# else
-# ifndef alloca /* predefined by HP cc +Olibcalls */
-char *alloca ();
-# endif
-# endif
+/* This blob per the Autoconf manual (under "Particular Functions"). */
+#if HAVE_ALLOCA_H
+# include <alloca.h>
+#elif defined __GNUC__
+# define alloca __builtin_alloca
+#elif defined _AIX
+# define alloca __alloca
+#elif defined _MSC_VER
+# include <malloc.h>
+# define alloca _alloca
+#else
+# include <stddef.h>
+# ifdef __cplusplus
+extern "C"
# endif
-#endif
-#if HAVE_MALLOC_H
-#include <malloc.h> /* alloca on mingw */
+void *alloca (size_t);
#endif
#include <assert.h>
@@ -4851,7 +4849,16 @@ tail:
switch (SCM_TYP7 (proc))
{
case scm_tc7_subr_2o:
- args = scm_is_null (args) ? SCM_UNDEFINED : SCM_CAR (args);
+ if (SCM_UNBNDP (arg1))
+ scm_wrong_num_args (proc);
+ if (scm_is_null (args))
+ args = SCM_UNDEFINED;
+ else
+ {
+ if (! scm_is_null (SCM_CDR (args)))
+ scm_wrong_num_args (proc);
+ args = SCM_CAR (args);
+ }
RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_2:
if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 8ac6bd246..72b45e92a 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -29,24 +29,22 @@
# include <config.h>
#endif
-/* AIX requires this to be the first thing in the file. The #pragma
- directive is indented so pre-ANSI compilers will ignore it, rather
- than choke on it. */
-#ifndef __GNUC__
-# if HAVE_ALLOCA_H
-# include <alloca.h>
-# else
-# ifdef _AIX
-# pragma alloca
-# else
-# ifndef alloca /* predefined by HP cc +Olibcalls */
-char *alloca ();
-# endif
-# endif
+/* This blob per the Autoconf manual (under "Particular Functions"). */
+#if HAVE_ALLOCA_H
+# include <alloca.h>
+#elif defined __GNUC__
+# define alloca __builtin_alloca
+#elif defined _AIX
+# define alloca __alloca
+#elif defined _MSC_VER
+# include <malloc.h>
+# define alloca _alloca
+#else
+# include <stddef.h>
+# ifdef __cplusplus
+extern "C"
# endif
-#endif
-#if HAVE_MALLOC_H
-#include <malloc.h> /* alloca on mingw, though its not used on that system */
+void *alloca (size_t);
#endif
#include <stdio.h>
@@ -202,10 +200,14 @@ char *alloca ();
# define fchmod(fd, mode) (-1)
#endif /* __MINGW32__ */
-/* This definition is for Solaris 10, it's probably not right elsewhere, but
- that's ok, it shouldn't be used elsewhere. */
-#if ! HAVE_DIRFD
-#define dirfd(dirstream) (dirstream->dd_fd)
+/* dirfd() returns the file descriptor underlying a "DIR*" directory stream.
+ Found on MacOS X for instance. The following definition is for Solaris
+ 10, it's probably not right elsewhere, but that's ok, it shouldn't be
+ used elsewhere. Crib note: If we need more then gnulib has a dirfd.m4
+ figuring out how to get the fd (dirfd function, dirfd macro, dd_fd field,
+ or d_fd field). */
+#ifndef dirfd
+#define dirfd(dirstream) ((dirstream)->dd_fd)
#endif
diff --git a/libguile/fports.c b/libguile/fports.c
index 742877eaf..f4c07af0d 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -17,6 +17,8 @@
+#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
+
#if HAVE_CONFIG_H
# include <config.h>
#endif
@@ -46,6 +48,7 @@
#endif
#include <errno.h>
+#include <sys/types.h>
#include "libguile/iselect.h"
@@ -53,9 +56,33 @@
#ifdef __MINGW32__
# include <sys/stat.h>
# include <winsock2.h>
-# define ftruncate(fd, size) chsize (fd, size)
#endif /* __MINGW32__ */
+/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
+ already, but have this code here in case that wasn't so in past versions,
+ or perhaps to help other minimal DOS environments.
+
+ gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
+ might be possibilities if we've got other systems without ftruncate. */
+
+#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
+# define ftruncate(fd, size) chsize (fd, size)
+#undef HAVE_FTRUNCATE
+#define HAVE_FTRUNCATE 1
+#endif
+
+#if SIZEOF_OFF_T == SIZEOF_INT
+#define OFF_T_MAX INT_MAX
+#define OFF_T_MIN INT_MIN
+#elif SIZEOF_OFF_T == SIZEOF_LONG
+#define OFF_T_MAX LONG_MAX
+#define OFF_T_MIN LONG_MIN
+#elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
+#define OFF_T_MAX LONG_LONG_MAX
+#define OFF_T_MIN LONG_LONG_MIN
+#else
+#error Oops, unknown OFF_T size
+#endif
scm_t_bits scm_tc16_fport;
@@ -334,7 +361,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
}
ptr++;
}
- SCM_SYSCALL (fdes = open (file, flags, 0666));
+ SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
if (fdes == -1)
{
int en = errno;
@@ -584,25 +611,25 @@ fport_fill_input (SCM port)
}
}
-static off_t
-fport_seek (SCM port, off_t offset, int whence)
+static off_t_or_off64_t
+fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
scm_t_fport *fp = SCM_FSTREAM (port);
- off_t rv;
- off_t result;
+ off_t_or_off64_t rv;
+ off_t_or_off64_t result;
if (pt->rw_active == SCM_PORT_WRITE)
{
if (offset != 0 || whence != SEEK_CUR)
{
fport_flush (port);
- result = rv = lseek (fp->fdes, offset, whence);
+ result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
}
else
{
/* read current position without disturbing the buffer. */
- rv = lseek (fp->fdes, offset, whence);
+ rv = lseek_or_lseek64 (fp->fdes, offset, whence);
result = rv + (pt->write_pos - pt->write_buf);
}
}
@@ -612,13 +639,13 @@ fport_seek (SCM port, off_t offset, int whence)
{
/* could expand to avoid a second seek. */
scm_end_input (port);
- result = rv = lseek (fp->fdes, offset, whence);
+ result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
}
else
{
/* read current position without disturbing the buffer
(particularly the unread-char buffer). */
- rv = lseek (fp->fdes, offset, whence);
+ rv = lseek_or_lseek64 (fp->fdes, offset, whence);
result = rv - (pt->read_end - pt->read_pos);
if (pt->read_buf == pt->putback_buf)
@@ -627,7 +654,7 @@ fport_seek (SCM port, off_t offset, int whence)
}
else /* SCM_PORT_NEITHER */
{
- result = rv = lseek (fp->fdes, offset, whence);
+ result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
}
if (rv == -1)
@@ -636,6 +663,39 @@ fport_seek (SCM port, off_t offset, int whence)
return result;
}
+/* If we've got largefile and off_t isn't already off64_t then
+ fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
+ the port descriptor.
+
+ Otherwise if no largefile, or off_t is the same as off64_t (which is the
+ case on NetBSD apparently), then fport_seek_or_seek64 is right to be
+ fport_seek already. */
+
+#if HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
+static off_t
+fport_seek (SCM port, off_t offset, int whence)
+{
+ off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
+ if (rv > OFF_T_MAX || rv < OFF_T_MIN)
+ {
+ errno = EOVERFLOW;
+ scm_syserror ("fport_seek");
+ }
+ return (off_t) rv;
+
+}
+#else
+#define fport_seek fport_seek_or_seek64
+#endif
+
+/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
+SCM
+scm_i_fport_seek (SCM port, SCM offset, int how)
+{
+ return scm_from_off_t_or_off64_t
+ (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
+}
+
static void
fport_truncate (SCM port, off_t length)
{
@@ -645,6 +705,13 @@ fport_truncate (SCM port, off_t length)
scm_syserror ("ftruncate");
}
+int
+scm_i_fport_truncate (SCM port, SCM length)
+{
+ scm_t_fport *fp = SCM_FSTREAM (port);
+ return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
+}
+
/* helper for fport_write: try to write data, using multiple system
calls if required. */
#define FUNC_NAME "write_all"
diff --git a/libguile/fports.h b/libguile/fports.h
index efc315792..634106760 100644
--- a/libguile/fports.h
+++ b/libguile/fports.h
@@ -58,6 +58,9 @@ SCM_API void scm_init_fports (void);
/* internal functions */
SCM_API SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name);
+SCM_API int scm_i_fport_truncate (SCM, SCM);
+SCM_API SCM scm_i_fport_seek (SCM, SCM, int);
+
#endif /* SCM_FPORTS_H */
diff --git a/libguile/gc.c b/libguile/gc.c
index d8b27d2f5..04e4e0a45 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -30,11 +30,6 @@
#include <string.h>
#include <assert.h>
-#ifdef __ia64__
-#include <ucontext.h>
-extern unsigned long * __libc_ia64_register_backing_store_base;
-#endif
-
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
@@ -224,18 +219,25 @@ unsigned long scm_mtrigger;
*/
unsigned long scm_cells_allocated = 0;
unsigned long scm_mallocated = 0;
-unsigned long scm_gc_cells_collected;
-unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */
-unsigned long scm_gc_malloc_collected;
-unsigned long scm_gc_ports_collected;
-unsigned long scm_gc_time_taken = 0;
+
+/* Global GC sweep statistics since the last full GC. */
+static scm_t_sweep_statistics scm_i_gc_sweep_stats = { 0, 0 };
+static scm_t_sweep_statistics scm_i_gc_sweep_stats_1 = { 0, 0 };
+
+/* Total count of cells marked/swept. */
+static double scm_gc_cells_marked_acc = 0.;
+static double scm_gc_cells_swept_acc = 0.;
+
+static unsigned long scm_gc_time_taken = 0;
static unsigned long t_before_gc;
-unsigned long scm_gc_mark_time_taken = 0;
-unsigned long scm_gc_times = 0;
-unsigned long scm_gc_cells_swept = 0;
-double scm_gc_cells_marked_acc = 0.;
-double scm_gc_cells_swept_acc = 0.;
-int scm_gc_cell_yield_percentage =0;
+static unsigned long scm_gc_mark_time_taken = 0;
+
+static unsigned long scm_gc_times = 0;
+
+static int scm_gc_cell_yield_percentage = 0;
+static unsigned long protected_obj_count = 0;
+
+/* The following are accessed from `gc-malloc.c' and `gc-card.c'. */
int scm_gc_malloc_yield_percentage = 0;
static unsigned long protected_obj_count = 0;
@@ -862,6 +864,44 @@ scm_init_gc ()
#include "libguile/gc.x"
}
+#ifdef __ia64__
+# ifdef __hpux
+# include <sys/param.h>
+# include <sys/pstat.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+ struct pst_vm_status vm_status;
+ int i = 0;
+ while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1)
+ if (vm_status.pst_type == PS_RSESTACK)
+ return (void *) vm_status.pst_vaddr;
+ abort ();
+}
+void *
+scm_ia64_ar_bsp (const void *ctx)
+{
+ uint64_t bsp;
+ __uc_get_ar_bsp(ctx, &bsp);
+ return (void *) bsp;
+}
+# endif /* hpux */
+# ifdef linux
+# include <ucontext.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+ extern void *__libc_ia64_register_backing_store_base;
+ return __libc_ia64_register_backing_store_base;
+}
+void *
+scm_ia64_ar_bsp (const void *opaque)
+{
+ ucontext_t *ctx = opaque;
+ return (void *) ctx->uc_mcontext.sc_ar_bsp;
+}
+# endif /* linux */
+#endif /* __ia64__ */
void
scm_gc_sweep (void)
diff --git a/libguile/gc.h b/libguile/gc.h
index 4ad21b462..f745b76a2 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -139,6 +139,11 @@ SCM_API scm_i_pthread_mutex_t scm_i_gc_admin_mutex;
#define scm_gc_running_p (SCM_I_CURRENT_THREAD->gc_running_p)
SCM_API scm_i_pthread_mutex_t scm_i_sweep_mutex;
+#ifdef __ia64__
+void *scm_ia64_register_backing_store_base (void);
+void *scm_ia64_ar_bsp (const void *);
+#endif
+
#if (SCM_ENABLE_DEPRECATED == 1)
@@ -165,13 +170,9 @@ SCM_API scm_i_pthread_key_t scm_i_freelist2;
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
-
-SCM_API unsigned long scm_gc_cells_swept;
-SCM_API unsigned long scm_gc_cells_collected;
SCM_API unsigned long scm_gc_malloc_collected;
SCM_API unsigned long scm_gc_ports_collected;
SCM_API unsigned long scm_cells_allocated;
-SCM_API int scm_gc_cell_yield_percentage;
SCM_API int scm_gc_malloc_yield_percentage;
SCM_API unsigned long scm_mallocated;
SCM_API unsigned long scm_mtrigger;
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index d162e395a..43a2a989d 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -378,6 +378,10 @@ main (int argc, char *argv[])
pf ("#define SCM_USE_NULL_THREADS %d /* 0 or 1 */\n",
SCM_I_GSC_USE_NULL_THREADS);
+ pf ("/* Define to 1 if need braces around PTHREAD_ONCE_INIT (for Solaris). */\n");
+ pf ("#define SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT %d /* 0 or 1 */\n",
+ SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT);
+
#if USE_DLL_IMPORT
pf ("\n");
pf ("/* Define some additional CPP macros on Win32 platforms. */\n");
diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in
index 8ceed8463..b4e0561f1 100644
--- a/libguile/gen-scmconfig.h.in
+++ b/libguile/gen-scmconfig.h.in
@@ -28,6 +28,7 @@
#define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@
#define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@
#define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@
+#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT@
/*
Local Variables:
diff --git a/libguile/gettext.c b/libguile/gettext.c
new file mode 100644
index 000000000..91a51439c
--- /dev/null
+++ b/libguile/gettext.c
@@ -0,0 +1,331 @@
+/* Copyright (C) 2004, 2006 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 as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/gettext.h"
+#include "libgettext.h"
+#include <locale.h>
+
+
+int
+scm_i_to_lc_category (SCM category, int allow_lc_all)
+{
+ int c_category = scm_to_int (category);
+ switch (c_category)
+ {
+#ifdef LC_CTYPE
+ case LC_CTYPE:
+#endif
+#ifdef LC_NUMERIC
+ case LC_NUMERIC:
+#endif
+#ifdef LC_COLLATE
+ case LC_COLLATE:
+#endif
+#ifdef LC_TIME
+ case LC_TIME:
+#endif
+#ifdef LC_MONETARY
+ case LC_MONETARY:
+#endif
+#ifdef LC_MESSAGES
+ case LC_MESSAGES:
+#endif
+#ifdef LC_PAPER
+ case LC_PAPER:
+#endif
+#ifdef LC_NAME
+ case LC_NAME:
+#endif
+#ifdef LC_ADDRESS
+ case LC_ADDRESS:
+#endif
+#ifdef LC_TELEPHONE
+ case LC_TELEPHONE:
+#endif
+#ifdef LC_MEASUREMENT
+ case LC_MEASUREMENT:
+#endif
+#ifdef LC_IDENTIFICATION
+ case LC_IDENTIFICATION:
+#endif
+ return c_category;
+#ifdef LC_ALL
+ case LC_ALL:
+ if (allow_lc_all)
+ return c_category;
+#endif
+ }
+ scm_wrong_type_arg (0, 0, category);
+}
+
+SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0,
+ (SCM msgid, SCM domain, SCM category),
+ "Return the translation of @var{msgid} in the message domain "
+ "@var{domain}. @var{domain} is optional and defaults to the "
+ "domain set through (textdomain). @var{category} is optional "
+ "and defaults to LC_MESSAGES.")
+#define FUNC_NAME s_scm_gettext
+{
+ char *c_msgid;
+ char const *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ c_msgid = scm_to_locale_string (msgid);
+ scm_dynwind_free (c_msgid);
+
+ if (SCM_UNBNDP (domain))
+ {
+ /* 1 argument case. */
+ c_result = gettext (c_msgid);
+ }
+ else
+ {
+ char *c_domain;
+
+ c_domain = scm_to_locale_string (domain);
+ scm_dynwind_free (c_domain);
+
+ if (SCM_UNBNDP (category))
+ {
+ /* 2 argument case. */
+ c_result = dgettext (c_domain, c_msgid);
+ }
+ else
+ {
+ /* 3 argument case. */
+ int c_category;
+
+ c_category = scm_i_to_lc_category (category, 0);
+ c_result = dcgettext (c_domain, c_msgid, c_category);
+ }
+ }
+
+ if (c_result == c_msgid)
+ result = msgid;
+ else
+ result = scm_from_locale_string (c_result);
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0,
+ (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category),
+ "Return the translation of @var{msgid}/@var{msgid_plural} in the "
+ "message domain @var{domain}, with the plural form being chosen "
+ "appropriately for the number @var{n}. @var{domain} is optional "
+ "and defaults to the domain set through (textdomain). "
+ "@var{category} is optional and defaults to LC_MESSAGES.")
+#define FUNC_NAME s_scm_ngettext
+{
+ char *c_msgid;
+ char *c_msgid_plural;
+ unsigned long c_n;
+ const char *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ c_msgid = scm_to_locale_string (msgid);
+ scm_dynwind_free (c_msgid);
+
+ c_msgid_plural = scm_to_locale_string (msgid_plural);
+ scm_dynwind_free (c_msgid_plural);
+
+ c_n = scm_to_ulong (n);
+
+ if (SCM_UNBNDP (domain))
+ {
+ /* 3 argument case. */
+ c_result = ngettext (c_msgid, c_msgid_plural, c_n);
+ }
+ else
+ {
+ char *c_domain;
+
+ c_domain = scm_to_locale_string (domain);
+ scm_dynwind_free (c_domain);
+
+ if (SCM_UNBNDP (category))
+ {
+ /* 4 argument case. */
+ c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n);
+ }
+ else
+ {
+ /* 5 argument case. */
+ int c_category;
+
+ c_category = scm_i_to_lc_category (category, 0);
+ c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n,
+ c_category);
+ }
+ }
+
+ if (c_result == c_msgid)
+ result = msgid;
+ else if (c_result == c_msgid_plural)
+ result = msgid_plural;
+ else
+ result = scm_from_locale_string (c_result);
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0,
+ (SCM domainname),
+ "If optional parameter @var{domainname} is supplied, "
+ "set the textdomain. "
+ "Return the textdomain.")
+#define FUNC_NAME s_scm_textdomain
+{
+ char const *c_result;
+ char *c_domain;
+ SCM result = SCM_BOOL_F;
+
+ scm_dynwind_begin (0);
+
+ if (SCM_UNBNDP (domainname))
+ c_domain = NULL;
+ else
+ {
+ c_domain = scm_to_locale_string (domainname);
+ scm_dynwind_free (c_domain);
+ }
+
+ c_result = textdomain (c_domain);
+ if (c_result != NULL)
+ result = scm_from_locale_string (c_result);
+ else if (!SCM_UNBNDP (domainname))
+ SCM_SYSERROR;
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0,
+ (SCM domainname, SCM directory),
+ "If optional parameter @var{directory} is supplied, "
+ "set message catalogs to directory @var{directory}. "
+ "Return the directory bound to @var{domainname}.")
+#define FUNC_NAME s_scm_bindtextdomain
+{
+ char *c_domain;
+ char *c_directory;
+ char const *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ if (SCM_UNBNDP (directory))
+ c_directory = NULL;
+ else
+ {
+ c_directory = scm_to_locale_string (directory);
+ scm_dynwind_free (c_directory);
+ }
+
+ c_domain = scm_to_locale_string (domainname);
+ scm_dynwind_free (c_domain);
+
+ c_result = bindtextdomain (c_domain, c_directory);
+
+ if (c_result != NULL)
+ result = scm_from_locale_string (c_result);
+ else if (!SCM_UNBNDP (directory))
+ SCM_SYSERROR;
+ else
+ result = SCM_BOOL_F;
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0,
+ (SCM domainname, SCM encoding),
+ "If optional parameter @var{encoding} is supplied, "
+ "set encoding for message catalogs of @var{domainname}. "
+ "Return the encoding of @var{domainname}.")
+#define FUNC_NAME s_scm_bind_textdomain_codeset
+{
+ char *c_domain;
+ char *c_encoding;
+ char const *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ if (SCM_UNBNDP (encoding))
+ c_encoding = NULL;
+ else
+ {
+ c_encoding = scm_to_locale_string (encoding);
+ scm_dynwind_free (c_encoding);
+ }
+
+ c_domain = scm_to_locale_string (domainname);
+ scm_dynwind_free (c_domain);
+
+ c_result = bind_textdomain_codeset (c_domain, c_encoding);
+
+ if (c_result != NULL)
+ result = scm_from_locale_string (c_result);
+ else if (!SCM_UNBNDP (encoding))
+ SCM_SYSERROR;
+ else
+ result = SCM_BOOL_F;
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+void
+scm_init_gettext ()
+{
+ /* When gettext support was first added (in 1.8.0), it provided feature
+ `i18n'. We keep this as is although the name is a bit misleading
+ now. */
+ scm_add_feature ("i18n");
+
+#include "libguile/gettext.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/gettext.h b/libguile/gettext.h
index f54b6bff7..4d91358e5 100644
--- a/libguile/gettext.h
+++ b/libguile/gettext.h
@@ -1,69 +1,41 @@
-/* Convenience header for conditional use of GNU <libintl.h>.
- Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc.
-
- This program is free software; you can redistribute it and/or modify it
- under the terms of the GNU Library General Public License as published
- by the Free Software Foundation; either version 2, or (at your option)
- any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Library General Public License for more details.
-
- You should have received a copy of the GNU Library General Public
- License along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
- USA. */
-
-#ifndef _LIBGETTEXT_H
-#define _LIBGETTEXT_H 1
-
-/* NLS can be disabled through the configure --disable-nls option. */
-#if ENABLE_NLS
-
-/* Get declarations of GNU message catalog functions. */
-# include <libintl.h>
-
-#else
-
-/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which
- chokes if dcgettext is defined as a macro. So include it now, to make
- later inclusions of <locale.h> a NOP. We don't include <libintl.h>
- as well because people using "gettext.h" will not include <libintl.h>,
- and also including <libintl.h> would fail on SunOS 4, whereas <locale.h>
- is OK. */
-#if defined(__sun)
-# include <locale.h>
-#endif
-
-/* Disabled NLS.
- The casts to 'const char *' serve the purpose of producing warnings
- for invalid uses of the value returned from these functions.
- On pre-ANSI systems without 'const', the config.h file is supposed to
- contain "#define const". */
-# define gettext(Msgid) ((const char *) (Msgid))
-# define dgettext(Domainname, Msgid) ((const char *) (Msgid))
-# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid))
-# define ngettext(Msgid1, Msgid2, N) \
- ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
-# define dngettext(Domainname, Msgid1, Msgid2, N) \
- ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
-# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \
- ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
-# define textdomain(Domainname) ((const char *) (Domainname))
-# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname))
-# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset))
-
-#endif
-
-/* A pseudo function call that serves as a marker for the automated
- extraction of messages, but does not call gettext(). The run-time
- translation is done at a different place in the code.
- The argument, String, should be a literal string. Concatenated strings
- and other string expressions won't work.
- The macro's expansion is not parenthesized, so that it is suitable as
- initializer for static 'char[]' or 'const char[]' variables. */
-#define gettext_noop(String) String
-
-#endif /* _LIBGETTEXT_H */
+/* classes: h_files */
+
+#ifndef SCM_GETTEXT_H
+#define SCM_GETTEXT_H
+
+/* Copyright (C) 2004, 2006 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 as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category);
+SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category);
+SCM_API SCM scm_textdomain (SCM domainname);
+SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory);
+SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding);
+
+SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all);
+
+SCM_API void scm_init_gettext (void);
+
+#endif /* SCM_GETTEXT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/i18n.c b/libguile/i18n.c
index 16e45e495..76dd9a514 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2006 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
@@ -15,308 +15,1142 @@
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
+#define _GNU_SOURCE /* Ask for glibc's `newlocale' API */
#if HAVE_CONFIG_H
# include <config.h>
#endif
+#if HAVE_ALLOCA_H
+# include <alloca.h>
+#elif defined __GNUC__
+# define alloca __builtin_alloca
+#elif defined _AIX
+# define alloca __alloca
+#elif defined _MSC_VER
+# include <malloc.h>
+# define alloca _alloca
+#else
+# include <stddef.h>
+# ifdef __cplusplus
+extern "C"
+# endif
+void *alloca (size_t);
+#endif
+
#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/i18n.h"
#include "libguile/strings.h"
+#include "libguile/chars.h"
#include "libguile/dynwind.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
-#include "gettext.h"
#include <locale.h>
+#include <string.h> /* `strcoll ()' */
+#include <ctype.h> /* `toupper ()' et al. */
+#include <errno.h>
-
-int
-scm_i_to_lc_category (SCM category, int allow_lc_all)
-{
- int c_category = scm_to_int (category);
- switch (c_category)
- {
-#ifdef LC_CTYPE
- case LC_CTYPE:
-#endif
-#ifdef LC_NUMERIC
- case LC_NUMERIC:
-#endif
-#ifdef LC_COLLATE
- case LC_COLLATE:
-#endif
-#ifdef LC_TIME
- case LC_TIME:
-#endif
-#ifdef LC_MONETARY
- case LC_MONETARY:
-#endif
-#ifdef LC_MESSAGES
- case LC_MESSAGES:
+#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
+# define USE_GNU_LOCALE_API
#endif
-#ifdef LC_PAPER
- case LC_PAPER:
+
+#ifndef USE_GNU_LOCALE_API
+# include "libguile/posix.h" /* for `scm_i_locale_mutex' */
#endif
-#ifdef LC_NAME
- case LC_NAME:
+
+#ifndef HAVE_SETLOCALE
+static inline char *
+setlocale (int category, const char *name)
+{
+ errno = ENOSYS;
+ return NULL;
+}
#endif
-#ifdef LC_ADDRESS
- case LC_ADDRESS:
+
+
+
+/* Locale objects, string and character collation, and other locale-dependent
+ string operations.
+
+ A large part of the code here deals with emulating glibc's reentrant
+ locale API on non-GNU systems. The emulation is a bit "brute-force":
+ Whenever a `-locale<?' procedure is passed a locale object, then:
+
+ 1. The `scm_t_locale_mutex' is locked.
+ 2. A series of `setlocale ()' call is performed to store the current
+ locale for each category in an `scm_t_locale_settings' object.
+ 3. A series of `setlocale ()' call is made to install each of the locale
+ categories of each of the base locales of each locale object,
+ recursively, starting from the last locale object of the chain.
+ 4. The settings captured in step (2) are restored.
+ 5. The `scm_t_locale_mutex' is released.
+
+ Hopefully, some smart standard will make that hack useless someday...
+ A similar API can be found in MzScheme starting from version 200:
+ http://download.plt-scheme.org/chronology/mzmr200alpha14.html .
+
+ Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
+ of the current _thread_ (unlike `setlocale ()') and doing so would require
+ maintaining per-thread locale information on non-GNU systems and always
+ re-installing this locale upon locale-dependent calls. */
+
+
+#ifndef USE_GNU_LOCALE_API
+
+/* Provide the locale category masks as found in glibc (copied from
+ <locale.h> as found in glibc 2.3.6). This must be kept in sync with
+ `locale-categories.h'. */
+
+# define LC_CTYPE_MASK (1 << LC_CTYPE)
+# define LC_COLLATE_MASK (1 << LC_COLLATE)
+# define LC_MESSAGES_MASK (1 << LC_MESSAGES)
+# define LC_MONETARY_MASK (1 << LC_MONETARY)
+# define LC_NUMERIC_MASK (1 << LC_NUMERIC)
+# define LC_TIME_MASK (1 << LC_TIME)
+
+# ifdef LC_PAPER
+# define LC_PAPER_MASK (1 << LC_PAPER)
+# else
+# define LC_PAPER_MASK 0
+# endif
+# ifdef LC_NAME
+# define LC_NAME_MASK (1 << LC_NAME)
+# else
+# define LC_NAME_MASK 0
+# endif
+# ifdef LC_ADDRESS
+# define LC_ADDRESS_MASK (1 << LC_ADDRESS)
+# else
+# define LC_ADDRESS_MASK 0
+# endif
+# ifdef LC_TELEPHONE
+# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE)
+# else
+# define LC_TELEPHONE_MASK 0
+# endif
+# ifdef LC_MEASUREMENT
+# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT)
+# else
+# define LC_MEASUREMENT_MASK 0
+# endif
+# ifdef LC_IDENTIFICATION
+# define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION)
+# else
+# define LC_IDENTIFICATION_MASK 0
+# endif
+
+# define LC_ALL_MASK (LC_CTYPE_MASK \
+ | LC_NUMERIC_MASK \
+ | LC_TIME_MASK \
+ | LC_COLLATE_MASK \
+ | LC_MONETARY_MASK \
+ | LC_MESSAGES_MASK \
+ | LC_PAPER_MASK \
+ | LC_NAME_MASK \
+ | LC_ADDRESS_MASK \
+ | LC_TELEPHONE_MASK \
+ | LC_MEASUREMENT_MASK \
+ | LC_IDENTIFICATION_MASK \
+ )
+
+/* Locale objects as returned by `make-locale' on non-GNU systems. */
+typedef struct scm_locale
+{
+ SCM base_locale; /* a `locale' object */
+ char *locale_name;
+ int category_mask;
+} *scm_t_locale;
+
+#else
+
+/* Alias for glibc's locale type. */
+typedef locale_t scm_t_locale;
+
#endif
-#ifdef LC_TELEPHONE
- case LC_TELEPHONE:
+
+/* Validate parameter ARG as a locale object and set C_LOCALE to the
+ corresponding C locale object. */
+#define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \
+ do \
+ { \
+ SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \
+ (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \
+ } \
+ while (0)
+
+/* Validate optional parameter ARG as either undefined or bound to a locale
+ object. Set C_LOCALE to the corresponding C locale object or NULL. */
+#define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \
+ do \
+ { \
+ if ((_arg) != SCM_UNDEFINED) \
+ SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \
+ else \
+ (_c_locale) = NULL; \
+ } \
+ while (0)
+
+
+SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0);
+
+SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
+{
+ scm_t_locale c_locale;
+
+ c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
+
+#ifdef USE_GNU_LOCALE_API
+ freelocale ((locale_t)c_locale);
+#else
+ c_locale->base_locale = SCM_UNDEFINED;
+ free (c_locale->locale_name);
+
+ scm_gc_free (c_locale, sizeof (* c_locale), "locale");
#endif
-#ifdef LC_MEASUREMENT
- case LC_MEASUREMENT:
+
+ return 0;
+}
+
+#ifndef USE_GNU_LOCALE_API
+static SCM
+smob_locale_mark (SCM locale)
+{
+ scm_t_locale c_locale;
+
+ c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
+ return (c_locale->base_locale);
+}
#endif
-#ifdef LC_IDENTIFICATION
- case LC_IDENTIFICATION:
+
+
+SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
+ (SCM category_mask, SCM locale_name, SCM base_locale),
+ "Return a reference to a data structure representing a set of "
+ "locale datasets. Unlike for the @var{category} parameter for "
+ "@code{setlocale}, the @var{category_mask} parameter here uses "
+ "a single bit for each category, made by OR'ing together "
+ "@code{LC_*_MASK} bits.")
+#define FUNC_NAME s_scm_make_locale
+{
+ SCM locale = SCM_BOOL_F;
+ int c_category_mask;
+ char *c_locale_name;
+ scm_t_locale c_base_locale, c_locale;
+
+ SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask);
+ SCM_VALIDATE_STRING (2, locale_name);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);
+
+ c_locale_name = scm_to_locale_string (locale_name);
+
+#ifdef USE_GNU_LOCALE_API
+
+ c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
+
+ if (!c_locale)
+ locale = SCM_BOOL_F;
+ else
+ SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
+
+ free (c_locale_name);
+
+#else
+
+ c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
+ c_locale->base_locale = base_locale;
+
+ c_locale->category_mask = c_category_mask;
+ c_locale->locale_name = c_locale_name;
+
+ SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
+
#endif
- return c_category;
-#ifdef LC_ALL
- case LC_ALL:
- if (allow_lc_all)
- return c_category;
-#endif
- }
- scm_wrong_type_arg (0, 0, category);
+
+ return locale;
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0,
- (SCM msgid, SCM domain, SCM category),
- "Return the translation of @var{msgid} in the message domain "
- "@var{domain}. @var{domain} is optional and defaults to the "
- "domain set through (textdomain). @var{category} is optional "
- "and defaults to LC_MESSAGES.")
-#define FUNC_NAME s_scm_gettext
+SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a locale object.")
+#define FUNC_NAME s_scm_locale_p
{
- char *c_msgid;
- char const *c_result;
- SCM result;
+ if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj))
+ return SCM_BOOL_T;
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+
+#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */
+
+
+/* Maximum number of chained locales (via `base_locale'). */
+#define LOCALE_STACK_SIZE_MAX 256
+
+typedef struct
+{
+#define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name;
+#include "locale-categories.h"
+#undef SCM_DEFINE_LOCALE_CATEGORY
+} scm_t_locale_settings;
+
+/* Fill out SETTINGS according to the current locale settings. On success
+ zero is returned and SETTINGS is properly initialized. */
+static int
+get_current_locale_settings (scm_t_locale_settings *settings)
+{
+ const char *locale_name;
+
+#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
+ { \
+ SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
+ if (!locale_name) \
+ goto handle_error; \
+ \
+ settings-> _name = strdup (locale_name); \
+ if (settings-> _name == NULL) \
+ goto handle_oom; \
+ }
+
+#include "locale-categories.h"
+#undef SCM_DEFINE_LOCALE_CATEGORY
+
+ return 0;
+
+ handle_error:
+ return errno;
- scm_dynwind_begin (0);
+ handle_oom:
+ return ENOMEM;
+}
+
+/* Restore locale settings SETTINGS. On success, return zero. */
+static int
+restore_locale_settings (const scm_t_locale_settings *settings)
+{
+ const char *result;
+
+#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
+ SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \
+ if (result == NULL) \
+ goto handle_error;
+
+#include "locale-categories.h"
+#undef SCM_DEFINE_LOCALE_CATEGORY
+
+ return 0;
+
+ handle_error:
+ return errno;
+}
+
+/* Free memory associated with SETTINGS. */
+static void
+free_locale_settings (scm_t_locale_settings *settings)
+{
+#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
+ free (settings-> _name); \
+ settings->_name = NULL;
+#include "locale-categories.h"
+#undef SCM_DEFINE_LOCALE_CATEGORY
+}
- c_msgid = scm_to_locale_string (msgid);
- scm_dynwind_free (c_msgid);
+/* Install the locale named LOCALE_NAME for all the categories listed in
+ CATEGORY_MASK. */
+static int
+install_locale_categories (const char *locale_name, int category_mask)
+{
+ const char *result;
- if (SCM_UNBNDP (domain))
+ if (category_mask == LC_ALL_MASK)
{
- /* 1 argument case. */
- c_result = gettext (c_msgid);
+ SCM_SYSCALL (result = setlocale (LC_ALL, locale_name));
+ if (result == NULL)
+ goto handle_error;
}
else
{
- char *c_domain;
+#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
+ if (category_mask & LC_ ## _name ## _MASK) \
+ { \
+ SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \
+ if (result == NULL) \
+ goto handle_error; \
+ }
+#include "locale-categories.h"
+#undef SCM_DEFINE_LOCALE_CATEGORY
+ }
- c_domain = scm_to_locale_string (domain);
- scm_dynwind_free (c_domain);
+ return 0;
- if (SCM_UNBNDP (category))
- {
- /* 2 argument case. */
- c_result = dgettext (c_domain, c_msgid);
- }
+ handle_error:
+ return errno;
+}
+
+/* Install LOCALE, recursively installing its base locales first. On
+ success, zero is returned. */
+static int
+install_locale (scm_t_locale locale)
+{
+ scm_t_locale stack[LOCALE_STACK_SIZE_MAX];
+ size_t stack_size = 0;
+ int stack_offset = 0;
+ const char *result = NULL;
+
+ /* Build up a locale stack by traversing the `base_locale' link. */
+ do
+ {
+ if (stack_size >= LOCALE_STACK_SIZE_MAX)
+ /* We cannot use `scm_error ()' here because otherwise the locale
+ mutex may remain locked. */
+ return EINVAL;
+
+ stack[stack_size++] = locale;
+
+ if (locale->base_locale != SCM_UNDEFINED)
+ locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale);
else
- {
- /* 3 argument case. */
- int c_category;
+ locale = NULL;
+ }
+ while (locale != NULL);
- c_category = scm_i_to_lc_category (category, 0);
- c_result = dcgettext (c_domain, c_msgid, c_category);
- }
+ /* Install the C locale to start from a pristine state. */
+ SCM_SYSCALL (result = setlocale (LC_ALL, "C"));
+ if (result == NULL)
+ goto handle_error;
+
+ /* Install the locales in reverse order. */
+ for (stack_offset = stack_size - 1;
+ stack_offset >= 0;
+ stack_offset--)
+ {
+ int err;
+ scm_t_locale locale;
+
+ locale = stack[stack_offset];
+ err = install_locale_categories (locale->locale_name,
+ locale->category_mask);
+ if (err)
+ goto handle_error;
}
- if (c_result == c_msgid)
- result = msgid;
- else
- result = scm_from_locale_string (c_result);
+ return 0;
- scm_dynwind_end ();
- return result;
+ handle_error:
+ return errno;
}
-#undef FUNC_NAME
+/* Leave the locked locale section. */
+static inline void
+leave_locale_section (const scm_t_locale_settings *settings)
+{
+ /* Restore the previous locale settings. */
+ (void)restore_locale_settings (settings);
+
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+}
-SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0,
- (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category),
- "Return the translation of @var{msgid}/@var{msgid_plural} in the "
- "message domain @var{domain}, with the plural form being chosen "
- "appropriately for the number @var{n}. @var{domain} is optional "
- "and defaults to the domain set through (textdomain). "
- "@var{category} is optional and defaults to LC_MESSAGES.")
-#define FUNC_NAME s_scm_ngettext
+/* Enter a locked locale section. */
+static inline int
+enter_locale_section (scm_t_locale locale,
+ scm_t_locale_settings *prev_locale)
{
- char *c_msgid;
- char *c_msgid_plural;
- unsigned long c_n;
- const char *c_result;
- SCM result;
+ int err;
+
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+
+ err = get_current_locale_settings (prev_locale);
+ if (err)
+ {
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+ return err;
+ }
- scm_dynwind_begin (0);
+ err = install_locale (locale);
+ if (err)
+ {
+ leave_locale_section (prev_locale);
+ free_locale_settings (prev_locale);
+ }
+
+ return err;
+}
+
+/* Throw an exception corresponding to error ERR. */
+static void inline
+scm_locale_error (const char *func_name, int err)
+{
+ SCM s_err;
+
+ s_err = scm_from_int (err);
+ scm_error (scm_system_error_key, func_name,
+ "Failed to install locale",
+ scm_cons (scm_strerror (s_err), SCM_EOL),
+ scm_cons (s_err, SCM_EOL));
+}
+
+/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
+#define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
+ do \
+ { \
+ int lsec_err; \
+ scm_t_locale_settings lsec_prev_locale; \
+ \
+ lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \
+ if (lsec_err) \
+ scm_locale_error (FUNC_NAME, lsec_err); \
+ else \
+ { \
+ _statement ; \
+ \
+ leave_locale_section (&lsec_prev_locale); \
+ free_locale_settings (&lsec_prev_locale); \
+ } \
+ } \
+ while (0)
+
+#endif /* !USE_GNU_LOCALE_API */
- c_msgid = scm_to_locale_string (msgid);
- scm_dynwind_free (c_msgid);
+
+/* Locale-dependent string comparison. */
- c_msgid_plural = scm_to_locale_string (msgid_plural);
- scm_dynwind_free (c_msgid_plural);
+/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return
+ an integer whose sign is the same as the difference between C_S1 and
+ C_S2. */
+static inline int
+compare_strings (const char *c_s1, const char *c_s2, SCM locale,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ int result;
+ scm_t_locale c_locale;
- c_n = scm_to_ulong (n);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
- if (SCM_UNBNDP (domain))
+ if (c_locale)
{
- /* 3 argument case. */
- c_result = ngettext (c_msgid, c_msgid_plural, c_n);
+#ifdef USE_GNU_LOCALE_API
+ result = strcoll_l (c_s1, c_s2, c_locale);
+#else
+#ifdef HAVE_STRCOLL
+ RUN_IN_LOCALE_SECTION (c_locale, result = strcoll (c_s1, c_s2));
+#else
+ result = strcmp (c_s1, c_s2);
+#endif
+#endif /* !USE_GNU_LOCALE_API */
}
else
+
+#ifdef HAVE_STRCOLL
+ result = strcoll (c_s1, c_s2);
+#else
+ result = strcmp (c_s1, c_s2);
+#endif
+
+ return result;
+}
+#undef FUNC_NAME
+
+/* Store into DST an upper-case version of SRC. */
+static inline void
+str_upcase (register char *dst, register const char *src)
+{
+ for (; *src != '\0'; src++, dst++)
+ *dst = toupper (*src);
+ *dst = '\0';
+}
+
+static inline void
+str_downcase (register char *dst, register const char *src)
+{
+ for (; *src != '\0'; src++, dst++)
+ *dst = tolower (*src);
+ *dst = '\0';
+}
+
+#ifdef USE_GNU_LOCALE_API
+static inline void
+str_upcase_l (register char *dst, register const char *src,
+ scm_t_locale locale)
+{
+ for (; *src != '\0'; src++, dst++)
+ *dst = toupper_l (*src, locale);
+ *dst = '\0';
+}
+
+static inline void
+str_downcase_l (register char *dst, register const char *src,
+ scm_t_locale locale)
+{
+ for (; *src != '\0'; src++, dst++)
+ *dst = tolower_l (*src, locale);
+ *dst = '\0';
+}
+#endif
+
+
+/* Compare null-terminated strings C_S1 and C_S2 in a case-independent way
+ according to LOCALE. Return an integer whose sign is the same as the
+ difference between C_S1 and C_S2. */
+static inline int
+compare_strings_ci (const char *c_s1, const char *c_s2, SCM locale,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ int result;
+ scm_t_locale c_locale;
+ char *c_us1, *c_us2;
+
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
+
+ c_us1 = (char *) alloca (strlen (c_s1) + 1);
+ c_us2 = (char *) alloca (strlen (c_s2) + 1);
+
+ if (c_locale)
{
- char *c_domain;
+#ifdef USE_GNU_LOCALE_API
+ str_upcase_l (c_us1, c_s1, c_locale);
+ str_upcase_l (c_us2, c_s2, c_locale);
- c_domain = scm_to_locale_string (domain);
- scm_dynwind_free (c_domain);
+ result = strcoll_l (c_us1, c_us2, c_locale);
+#else
+ int err;
+ scm_t_locale_settings prev_locale;
- if (SCM_UNBNDP (category))
+ err = enter_locale_section (c_locale, &prev_locale);
+ if (err)
{
- /* 4 argument case. */
- c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n);
+ scm_locale_error (func_name, err);
+ return 0;
}
- else
- {
- /* 5 argument case. */
- int c_category;
- c_category = scm_i_to_lc_category (category, 0);
- c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n,
- c_category);
- }
- }
+ str_upcase (c_us1, c_s1);
+ str_upcase (c_us2, c_s2);
+
+#ifdef HAVE_STRCOLL
+ result = strcoll (c_us1, c_us2);
+#else
+ result = strcmp (c_us1, c_us2);
+#endif /* !HAVE_STRCOLL */
- if (c_result == c_msgid)
- result = msgid;
- else if (c_result == c_msgid_plural)
- result = msgid_plural;
+ leave_locale_section (&prev_locale);
+ free_locale_settings (&prev_locale);
+#endif /* !USE_GNU_LOCALE_API */
+ }
else
- result = scm_from_locale_string (c_result);
-
- scm_dynwind_end ();
+ {
+ str_upcase (c_us1, c_s1);
+ str_upcase (c_us2, c_s2);
+
+#ifdef HAVE_STRCOLL
+ result = strcoll (c_us1, c_us2);
+#else
+ result = strcmp (c_us1, c_us2);
+#endif
+ }
+
return result;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0,
- (SCM domainname),
- "If optional parameter @var{domainname} is supplied, "
- "set the textdomain. "
- "Return the textdomain.")
-#define FUNC_NAME s_scm_textdomain
+
+SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
+ (SCM s1, SCM s2, SCM locale),
+ "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
+ "If @var{locale} is provided, it should be locale object (as "
+ "returned by @code{make-locale}) and will be used to perform the "
+ "comparison; otherwise, the current system locale is used.")
+#define FUNC_NAME s_scm_string_locale_lt
{
- char const *c_result;
- char *c_domain;
- SCM result = SCM_BOOL_F;
+ int result;
+ const char *c_s1, *c_s2;
- scm_dynwind_begin (0);
+ SCM_VALIDATE_STRING (1, s1);
+ SCM_VALIDATE_STRING (2, s2);
- if (SCM_UNBNDP (domainname))
- c_domain = NULL;
- else
+ c_s1 = scm_i_string_chars (s1);
+ c_s2 = scm_i_string_chars (s2);
+
+ result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
+
+ scm_remember_upto_here_2 (s1, s2);
+
+ return scm_from_bool (result < 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0,
+ (SCM s1, SCM s2, SCM locale),
+ "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
+ "If @var{locale} is provided, it should be locale object (as "
+ "returned by @code{make-locale}) and will be used to perform the "
+ "comparison; otherwise, the current system locale is used.")
+#define FUNC_NAME s_scm_string_locale_gt
+{
+ int result;
+ const char *c_s1, *c_s2;
+
+ SCM_VALIDATE_STRING (1, s1);
+ SCM_VALIDATE_STRING (2, s2);
+
+ c_s1 = scm_i_string_chars (s1);
+ c_s2 = scm_i_string_chars (s2);
+
+ result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
+
+ scm_remember_upto_here_2 (s1, s2);
+
+ return scm_from_bool (result > 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0,
+ (SCM s1, SCM s2, SCM locale),
+ "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
+ "and locale-dependent way. If @var{locale} is provided, it "
+ "should be locale object (as returned by @code{make-locale}) "
+ "and will be used to perform the comparison; otherwise, the "
+ "current system locale is used.")
+#define FUNC_NAME s_scm_string_locale_ci_lt
+{
+ int result;
+ const char *c_s1, *c_s2;
+
+ SCM_VALIDATE_STRING (1, s1);
+ SCM_VALIDATE_STRING (2, s2);
+
+ c_s1 = scm_i_string_chars (s1);
+ c_s2 = scm_i_string_chars (s2);
+
+ result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
+
+ scm_remember_upto_here_2 (s1, s2);
+
+ return scm_from_bool (result < 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0,
+ (SCM s1, SCM s2, SCM locale),
+ "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
+ "and locale-dependent way. If @var{locale} is provided, it "
+ "should be locale object (as returned by @code{make-locale}) "
+ "and will be used to perform the comparison; otherwise, the "
+ "current system locale is used.")
+#define FUNC_NAME s_scm_string_locale_ci_gt
+{
+ int result;
+ const char *c_s1, *c_s2;
+
+ SCM_VALIDATE_STRING (1, s1);
+ SCM_VALIDATE_STRING (2, s2);
+
+ c_s1 = scm_i_string_chars (s1);
+ c_s2 = scm_i_string_chars (s2);
+
+ result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
+
+ scm_remember_upto_here_2 (s1, s2);
+
+ return scm_from_bool (result > 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0,
+ (SCM s1, SCM s2, SCM locale),
+ "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
+ "and locale-dependent way. If @var{locale} is provided, it "
+ "should be locale object (as returned by @code{make-locale}) "
+ "and will be used to perform the comparison; otherwise, the "
+ "current system locale is used.")
+#define FUNC_NAME s_scm_string_locale_ci_eq
+{
+ int result;
+ const char *c_s1, *c_s2;
+
+ SCM_VALIDATE_STRING (1, s1);
+ SCM_VALIDATE_STRING (2, s2);
+
+ c_s1 = scm_i_string_chars (s1);
+ c_s2 = scm_i_string_chars (s2);
+
+ result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
+
+ scm_remember_upto_here_2 (s1, s2);
+
+ return scm_from_bool (result == 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0,
+ (SCM c1, SCM c2, SCM locale),
+ "Return true if character @var{c1} is lower than @var{c2} "
+ "according to @var{locale} or to the current locale.")
+#define FUNC_NAME s_scm_char_locale_lt
+{
+ char c_c1[2], c_c2[2];
+
+ SCM_VALIDATE_CHAR (1, c1);
+ SCM_VALIDATE_CHAR (2, c2);
+
+ c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
+ c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+
+ return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) < 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0,
+ (SCM c1, SCM c2, SCM locale),
+ "Return true if character @var{c1} is greater than @var{c2} "
+ "according to @var{locale} or to the current locale.")
+#define FUNC_NAME s_scm_char_locale_gt
+{
+ char c_c1[2], c_c2[2];
+
+ SCM_VALIDATE_CHAR (1, c1);
+ SCM_VALIDATE_CHAR (2, c2);
+
+ c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
+ c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+
+ return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) > 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0,
+ (SCM c1, SCM c2, SCM locale),
+ "Return true if character @var{c1} is lower than @var{c2}, "
+ "in a case insensitive way according to @var{locale} or to "
+ "the current locale.")
+#define FUNC_NAME s_scm_char_locale_ci_lt
+{
+ int result;
+ char c_c1[2], c_c2[2];
+
+ SCM_VALIDATE_CHAR (1, c1);
+ SCM_VALIDATE_CHAR (2, c2);
+
+ c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
+ c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+
+ result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+
+ return scm_from_bool (result < 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0,
+ (SCM c1, SCM c2, SCM locale),
+ "Return true if character @var{c1} is greater than @var{c2}, "
+ "in a case insensitive way according to @var{locale} or to "
+ "the current locale.")
+#define FUNC_NAME s_scm_char_locale_ci_gt
+{
+ int result;
+ char c_c1[2], c_c2[2];
+
+ SCM_VALIDATE_CHAR (1, c1);
+ SCM_VALIDATE_CHAR (2, c2);
+
+ c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
+ c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+
+ result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+
+ return scm_from_bool (result > 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
+ (SCM c1, SCM c2, SCM locale),
+ "Return true if character @var{c1} is equal to @var{c2}, "
+ "in a case insensitive way according to @var{locale} or to "
+ "the current locale.")
+#define FUNC_NAME s_scm_char_locale_ci_eq
+{
+ int result;
+ char c_c1[2], c_c2[2];
+
+ SCM_VALIDATE_CHAR (1, c1);
+ SCM_VALIDATE_CHAR (2, c2);
+
+ c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
+ c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+
+ result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+
+ return scm_from_bool (result == 0);
+}
+#undef FUNC_NAME
+
+
+
+/* Locale-dependent alphabetic character mapping. */
+
+SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
+ (SCM chr, SCM locale),
+ "Return the lowercase character that corresponds to @var{chr} "
+ "according to either @var{locale} or the current locale.")
+#define FUNC_NAME s_scm_char_locale_downcase
+{
+ char c_chr;
+ int c_result;
+ scm_t_locale c_locale;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ c_chr = SCM_CHAR (chr);
+
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+
+ if (c_locale != NULL)
{
- c_domain = scm_to_locale_string (domainname);
- scm_dynwind_free (c_domain);
+#ifdef USE_GNU_LOCALE_API
+ c_result = tolower_l (c_chr, c_locale);
+#else
+ RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower (c_chr));
+#endif
}
+ else
+ c_result = tolower (c_chr);
- c_result = textdomain (c_domain);
- if (c_result != NULL)
- result = scm_from_locale_string (c_result);
- else if (!SCM_UNBNDP (domainname))
- SCM_SYSERROR;
-
- scm_dynwind_end ();
- return result;
+ return (SCM_MAKE_CHAR (c_result));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0,
- (SCM domainname, SCM directory),
- "If optional parameter @var{directory} is supplied, "
- "set message catalogs to directory @var{directory}. "
- "Return the directory bound to @var{domainname}.")
-#define FUNC_NAME s_scm_bindtextdomain
+SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0,
+ (SCM chr, SCM locale),
+ "Return the uppercase character that corresponds to @var{chr} "
+ "according to either @var{locale} or the current locale.")
+#define FUNC_NAME s_scm_char_locale_upcase
{
- char *c_domain;
- char *c_directory;
- char const *c_result;
- SCM result;
+ char c_chr;
+ int c_result;
+ scm_t_locale c_locale;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ c_chr = SCM_CHAR (chr);
- scm_dynwind_begin (0);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
- if (SCM_UNBNDP (directory))
- c_directory = NULL;
+ if (c_locale != NULL)
+ {
+#ifdef USE_GNU_LOCALE_API
+ c_result = toupper_l (c_chr, c_locale);
+#else
+ RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper (c_chr));
+#endif
+ }
else
+ c_result = toupper (c_chr);
+
+ return (SCM_MAKE_CHAR (c_result));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
+ (SCM str, SCM locale),
+ "Return a new string that is the uppercase version of "
+ "@var{str} according to either @var{locale} or the current "
+ "locale.")
+#define FUNC_NAME s_scm_string_locale_upcase
+{
+ const char *c_str;
+ char *c_ustr;
+ scm_t_locale c_locale;
+
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+
+ c_str = scm_i_string_chars (str);
+ c_ustr = (char *) alloca (strlen (c_str) + 1);
+
+ if (c_locale)
{
- c_directory = scm_to_locale_string (directory);
- scm_dynwind_free (c_directory);
+#ifdef USE_GNU_LOCALE_API
+ str_upcase_l (c_ustr, c_str, c_locale);
+#else
+ RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str));
+#endif
}
+ else
+ str_upcase (c_ustr, c_str);
+
+ scm_remember_upto_here (str);
+
+ return (scm_from_locale_string (c_ustr));
+}
+#undef FUNC_NAME
- c_domain = scm_to_locale_string (domainname);
- scm_dynwind_free (c_domain);
+SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0,
+ (SCM str, SCM locale),
+ "Return a new string that is the down-case version of "
+ "@var{str} according to either @var{locale} or the current "
+ "locale.")
+#define FUNC_NAME s_scm_string_locale_downcase
+{
+ const char *c_str;
+ char *c_lstr;
+ scm_t_locale c_locale;
+
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
- c_result = bindtextdomain (c_domain, c_directory);
+ c_str = scm_i_string_chars (str);
+ c_lstr = (char *) alloca (strlen (c_str) + 1);
- if (c_result != NULL)
- result = scm_from_locale_string (c_result);
- else if (!SCM_UNBNDP (directory))
- SCM_SYSERROR;
+ if (c_locale)
+ {
+#ifdef USE_GNU_LOCALE_API
+ str_downcase_l (c_lstr, c_str, c_locale);
+#else
+ RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str));
+#endif
+ }
else
- result = SCM_BOOL_F;
+ str_downcase (c_lstr, c_str);
- scm_dynwind_end ();
- return result;
+ scm_remember_upto_here (str);
+
+ return (scm_from_locale_string (c_lstr));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0,
- (SCM domainname, SCM encoding),
- "If optional parameter @var{encoding} is supplied, "
- "set encoding for message catalogs of @var{domainname}. "
- "Return the encoding of @var{domainname}.")
-#define FUNC_NAME s_scm_bind_textdomain_codeset
+/* Note: We don't provide mutative versions of `string-locale-(up|down)case'
+ because, in some languages, a single downcase character maps to a couple
+ of uppercase characters. Read the SRFI-13 document for a detailed
+ discussion about this. */
+
+
+
+/* Locale-dependent number parsing. */
+
+SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
+ 1, 2, 0, (SCM str, SCM base, SCM locale),
+ "Convert string @var{str} into an integer according to either "
+ "@var{locale} (a locale object as returned by @code{make-locale}) "
+ "or the current process locale. Return two values: an integer "
+ "(on success) or @code{#f}, and the number of characters read "
+ "from @var{str} (@code{0} on failure).")
+#define FUNC_NAME s_scm_locale_string_to_integer
{
- char *c_domain;
- char *c_encoding;
- char const *c_result;
SCM result;
+ long c_result;
+ int c_base;
+ const char *c_str;
+ char *c_endptr;
+ scm_t_locale c_locale;
- scm_dynwind_begin (0);
+ SCM_VALIDATE_STRING (1, str);
+ c_str = scm_i_string_chars (str);
- if (SCM_UNBNDP (encoding))
- c_encoding = NULL;
+ if (base != SCM_UNDEFINED)
+ SCM_VALIDATE_INT_COPY (2, base, c_base);
else
+ c_base = 10;
+
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
+
+ if (c_locale != NULL)
{
- c_encoding = scm_to_locale_string (encoding);
- scm_dynwind_free (c_encoding);
+#ifdef USE_GNU_LOCALE_API
+ c_result = strtol_l (c_str, &c_endptr, c_base, c_locale);
+#else
+ RUN_IN_LOCALE_SECTION (c_locale,
+ c_result = strtol (c_str, &c_endptr, c_base));
+#endif
}
+ else
+ c_result = strtol (c_str, &c_endptr, c_base);
+
+ scm_remember_upto_here (str);
+
+ if (c_endptr == c_str)
+ result = SCM_BOOL_F;
+ else
+ result = scm_from_long (c_result);
+
+ return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
+ 1, 1, 0, (SCM str, SCM locale),
+ "Convert string @var{str} into an inexact number according to "
+ "either @var{locale} (a locale object as returned by "
+ "@code{make-locale}) or the current process locale. Return "
+ "two values: an inexact number (on success) or @code{#f}, and "
+ "the number of characters read from @var{str} (@code{0} on "
+ "failure).")
+#define FUNC_NAME s_scm_locale_string_to_inexact
+{
+ SCM result;
+ double c_result;
+ const char *c_str;
+ char *c_endptr;
+ scm_t_locale c_locale;
- c_domain = scm_to_locale_string (domainname);
- scm_dynwind_free (c_domain);
+ SCM_VALIDATE_STRING (1, str);
+ c_str = scm_i_string_chars (str);
- c_result = bind_textdomain_codeset (c_domain, c_encoding);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
- if (c_result != NULL)
- result = scm_from_locale_string (c_result);
- else if (!SCM_UNBNDP (encoding))
- SCM_SYSERROR;
+ if (c_locale != NULL)
+ {
+#ifdef USE_GNU_LOCALE_API
+ c_result = strtod_l (c_str, &c_endptr, c_locale);
+#else
+ RUN_IN_LOCALE_SECTION (c_locale,
+ c_result = strtod (c_str, &c_endptr));
+#endif
+ }
else
+ c_result = strtod (c_str, &c_endptr);
+
+ scm_remember_upto_here (str);
+
+ if (c_endptr == c_str)
result = SCM_BOOL_F;
+ else
+ result = scm_from_double (c_result);
- scm_dynwind_end ();
- return result;
+ return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
}
#undef FUNC_NAME
-void
+
+
+void
scm_init_i18n ()
{
- scm_add_feature ("i18n");
+ scm_add_feature ("ice-9-i18n");
+
+#define _SCM_STRINGIFY_LC(_name) # _name
+#define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name)
+
+ /* Define all the relevant `_MASK' variables. */
+#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
+ scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \
+ SCM_I_MAKINUM (LC_ ## _name ## _MASK));
+#include "locale-categories.h"
+
+#undef SCM_DEFINE_LOCALE_CATEGORY
+#undef SCM_STRINGIFY_LC
+#undef _SCM_STRINGIFY_LC
+
+ scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK));
+
#include "libguile/i18n.x"
+
+#ifndef USE_GNU_LOCALE_API
+ scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark);
+#endif
}
diff --git a/libguile/i18n.h b/libguile/i18n.h
index 1f0cb0852..7d5d9baa9 100644
--- a/libguile/i18n.h
+++ b/libguile/i18n.h
@@ -3,7 +3,7 @@
#ifndef SCM_I18N_H
#define SCM_I18N_H
-/* Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2006 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
@@ -22,13 +22,24 @@
#include "libguile/__scm.h"
-SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category);
-SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category);
-SCM_API SCM scm_textdomain (SCM domainname);
-SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory);
-SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding);
-
-SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all);
+SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale);
+SCM_API SCM scm_locale_p (SCM obj);
+SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale);
+SCM_API SCM scm_string_locale_gt (SCM s1, SCM s2, SCM locale);
+SCM_API SCM scm_string_locale_ci_lt (SCM s1, SCM s2, SCM locale);
+SCM_API SCM scm_string_locale_ci_gt (SCM s1, SCM s2, SCM locale);
+SCM_API SCM scm_string_locale_ci_eq (SCM s1, SCM s2, SCM locale);
+SCM_API SCM scm_char_locale_lt (SCM c1, SCM c2, SCM locale);
+SCM_API SCM scm_char_locale_gt (SCM c1, SCM c2, SCM locale);
+SCM_API SCM scm_char_locale_ci_lt (SCM c1, SCM c2, SCM locale);
+SCM_API SCM scm_char_locale_ci_gt (SCM c1, SCM c2, SCM locale);
+SCM_API SCM scm_char_locale_ci_eq (SCM c1, SCM c2, SCM locale);
+SCM_API SCM scm_char_locale_upcase (SCM chr, SCM locale);
+SCM_API SCM scm_char_locale_downcase (SCM chr, SCM locale);
+SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale);
+SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale);
+SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale);
+SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale);
SCM_API void scm_init_i18n (void);
diff --git a/libguile/init.c b/libguile/init.c
index 46919f0fe..664aee63a 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -46,7 +46,9 @@
#include "libguile/deprecation.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
+#if 0
#include "libguile/environments.h"
+#endif
#include "libguile/eq.h"
#include "libguile/error.h"
#include "libguile/eval.h"
@@ -63,7 +65,7 @@
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/hooks.h"
-#include "libguile/i18n.h"
+#include "libguile/gettext.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
@@ -436,7 +438,9 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_struct_prehistory (); /* requires storage */
scm_symbols_prehistory (); /* requires storage */
scm_init_subr_table ();
+#if 0
scm_environments_prehistory (); /* requires storage */
+#endif
scm_modules_prehistory (); /* requires storage and hash tables */
scm_init_variable (); /* all bindings need variables */
scm_init_continuations ();
@@ -445,7 +449,9 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_gsubr ();
scm_init_thread_procs (); /* requires gsubrs */
scm_init_procprop ();
+#if 0
scm_init_environments ();
+#endif
scm_init_alist ();
scm_init_arbiters ();
scm_init_async ();
@@ -475,7 +481,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_properties ();
scm_init_hooks (); /* Requires smob_prehistory */
scm_init_gc (); /* Requires hooks, async */
- scm_init_i18n ();
+ scm_init_gettext ();
scm_init_ioext ();
scm_init_keywords ();
scm_init_list ();
diff --git a/libguile/libgettext.h b/libguile/libgettext.h
new file mode 100644
index 000000000..f54b6bff7
--- /dev/null
+++ b/libguile/libgettext.h
@@ -0,0 +1,69 @@
+/* Convenience header for conditional use of GNU <libintl.h>.
+ Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published
+ by the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Library General Public License for more details.
+
+ You should have received a copy of the GNU Library General Public
+ License along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+ USA. */
+
+#ifndef _LIBGETTEXT_H
+#define _LIBGETTEXT_H 1
+
+/* NLS can be disabled through the configure --disable-nls option. */
+#if ENABLE_NLS
+
+/* Get declarations of GNU message catalog functions. */
+# include <libintl.h>
+
+#else
+
+/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which
+ chokes if dcgettext is defined as a macro. So include it now, to make
+ later inclusions of <locale.h> a NOP. We don't include <libintl.h>
+ as well because people using "gettext.h" will not include <libintl.h>,
+ and also including <libintl.h> would fail on SunOS 4, whereas <locale.h>
+ is OK. */
+#if defined(__sun)
+# include <locale.h>
+#endif
+
+/* Disabled NLS.
+ The casts to 'const char *' serve the purpose of producing warnings
+ for invalid uses of the value returned from these functions.
+ On pre-ANSI systems without 'const', the config.h file is supposed to
+ contain "#define const". */
+# define gettext(Msgid) ((const char *) (Msgid))
+# define dgettext(Domainname, Msgid) ((const char *) (Msgid))
+# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid))
+# define ngettext(Msgid1, Msgid2, N) \
+ ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
+# define dngettext(Domainname, Msgid1, Msgid2, N) \
+ ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
+# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \
+ ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
+# define textdomain(Domainname) ((const char *) (Domainname))
+# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname))
+# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset))
+
+#endif
+
+/* A pseudo function call that serves as a marker for the automated
+ extraction of messages, but does not call gettext(). The run-time
+ translation is done at a different place in the code.
+ The argument, String, should be a literal string. Concatenated strings
+ and other string expressions won't work.
+ The macro's expansion is not parenthesized, so that it is suitable as
+ initializer for static 'char[]' or 'const char[]' variables. */
+#define gettext_noop(String) String
+
+#endif /* _LIBGETTEXT_H */
diff --git a/libguile/locale-categories.h b/libguile/locale-categories.h
new file mode 100644
index 000000000..cec91fb91
--- /dev/null
+++ b/libguile/locale-categories.h
@@ -0,0 +1,47 @@
+/* Copyright (C) 2006 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 as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+/* A list of all available locale categories, not including `ALL'. */
+
+
+/* The six standard categories, as defined in IEEE Std 1003.1-2001. */
+SCM_DEFINE_LOCALE_CATEGORY (COLLATE)
+SCM_DEFINE_LOCALE_CATEGORY (CTYPE)
+SCM_DEFINE_LOCALE_CATEGORY (MESSAGES)
+SCM_DEFINE_LOCALE_CATEGORY (MONETARY)
+SCM_DEFINE_LOCALE_CATEGORY (NUMERIC)
+SCM_DEFINE_LOCALE_CATEGORY (TIME)
+
+/* Additional non-standard categories. */
+#ifdef LC_PAPER
+SCM_DEFINE_LOCALE_CATEGORY (PAPER)
+#endif
+#ifdef LC_NAME
+SCM_DEFINE_LOCALE_CATEGORY (NAME)
+#endif
+#ifdef LC_ADDRESS
+SCM_DEFINE_LOCALE_CATEGORY (ADDRESS)
+#endif
+#ifdef LC_TELEPHONE
+SCM_DEFINE_LOCALE_CATEGORY (TELEPHONE)
+#endif
+#ifdef LC_MEASUREMENT
+SCM_DEFINE_LOCALE_CATEGORY (MEASUREMENT)
+#endif
+#ifdef LC_IDENTIFICATION
+SCM_DEFINE_LOCALE_CATEGORY (IDENTIFICATION)
+#endif
diff --git a/libguile/modules.c b/libguile/modules.c
index 40936cb44..b1f312a92 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -273,8 +273,9 @@ SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
/*
* C level implementation of the standard eval closure
*
- * This increases loading speed substantially.
- * The code will be replaced by the low-level environments in next release.
+ * This increases loading speed substantially. The code may be
+ * replaced by something based on environments.[ch], in a future
+ * release.
*/
static SCM module_make_local_var_x_var;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 1a662b015..3be5314e0 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -40,7 +40,7 @@
*/
-/* tell glibc (2.3) to give prototype for C99 trunc() */
+/* tell glibc (2.3) to give prototype for C99 trunc(), csqrt(), etc */
#define _GNU_SOURCE
#if HAVE_CONFIG_H
@@ -51,6 +51,10 @@
#include <ctype.h>
#include <string.h>
+#if HAVE_COMPLEX_H
+#include <complex.h>
+#endif
+
#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/ports.h"
@@ -66,6 +70,14 @@
#include "libguile/discouraged.h"
+/* values per glibc, if not already defined */
+#ifndef M_LOG10E
+#define M_LOG10E 0.43429448190325182765
+#endif
+#ifndef M_PI
+#define M_PI 3.14159265358979323846
+#endif
+
/*
@@ -150,6 +162,21 @@ xisnan (double x)
#endif
}
+
+/* For an SCM object Z which is a complex number (ie. satisfies
+ SCM_COMPLEXP), return its value as a C level "complex double". */
+#define SCM_COMPLEX_VALUE(z) \
+ (SCM_COMPLEX_REAL (z) + _Complex_I * SCM_COMPLEX_IMAG (z))
+
+/* Convert a C "complex double" to an SCM value. */
+#if HAVE_COMPLEX_DOUBLE
+static SCM
+scm_from_complex_double (complex double z)
+{
+ return scm_c_make_rectangular (creal (z), cimag (z));
+}
+#endif /* HAVE_COMPLEX_DOUBLE */
+
static mpz_t z_negative_one;
@@ -5978,6 +6005,142 @@ scm_is_number (SCM z)
return scm_is_true (scm_number_p (z));
}
+
+/* In the following functions we dispatch to the real-arg funcs like log()
+ when we know the arg is real, instead of just handing everything to
+ clog() for instance. This is in case clog() doesn't optimize for a
+ real-only case, and because we have to test SCM_COMPLEXP anyway so may as
+ well use it to go straight to the applicable C func. */
+
+SCM_DEFINE (scm_log, "log", 1, 0, 0,
+ (SCM z),
+ "Return the natural logarithm of @var{z}.")
+#define FUNC_NAME s_scm_log
+{
+ if (SCM_COMPLEXP (z))
+ {
+#if HAVE_COMPLEX_DOUBLE
+ return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
+#else
+ double re = SCM_COMPLEX_REAL (z);
+ double im = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (log (hypot (re, im)),
+ atan2 (im, re));
+#endif
+ }
+ else
+ {
+ /* ENHANCE-ME: When z is a bignum the logarithm will fit a double
+ although the value itself overflows. */
+ double re = scm_to_double (z);
+ double l = log (fabs (re));
+ if (re >= 0.0)
+ return scm_from_double (l);
+ else
+ return scm_c_make_rectangular (l, M_PI);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_log10, "log10", 1, 0, 0,
+ (SCM z),
+ "Return the base 10 logarithm of @var{z}.")
+#define FUNC_NAME s_scm_log10
+{
+ if (SCM_COMPLEXP (z))
+ {
+ /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
+ clog() and a multiply by M_LOG10E, rather than the fallback
+ log10+hypot+atan2.) */
+#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG10
+ return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z)));
+#else
+ double re = SCM_COMPLEX_REAL (z);
+ double im = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (log10 (hypot (re, im)),
+ M_LOG10E * atan2 (im, re));
+#endif
+ }
+ else
+ {
+ /* ENHANCE-ME: When z is a bignum the logarithm will fit a double
+ although the value itself overflows. */
+ double re = scm_to_double (z);
+ double l = log10 (fabs (re));
+ if (re >= 0.0)
+ return scm_from_double (l);
+ else
+ return scm_c_make_rectangular (l, M_LOG10E * M_PI);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_exp, "exp", 1, 0, 0,
+ (SCM z),
+ "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
+ "base of natural logarithms (2.71828@dots{}).")
+#define FUNC_NAME s_scm_exp
+{
+ if (SCM_COMPLEXP (z))
+ {
+#if HAVE_COMPLEX_DOUBLE
+ return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
+#else
+ return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
+ SCM_COMPLEX_IMAG (z));
+#endif
+ }
+ else
+ {
+ /* When z is a negative bignum the conversion to double overflows,
+ giving -infinity, but that's ok, the exp is still 0.0. */
+ return scm_from_double (exp (scm_to_double (z)));
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sqrt, "sqrt", 1, 0, 0,
+ (SCM x),
+ "Return the square root of @var{z}. Of the two possible roots\n"
+ "(positive and negative), the one with the a positive real part\n"
+ "is returned, or if that's zero then a positive imaginary part.\n"
+ "Thus,\n"
+ "\n"
+ "@example\n"
+ "(sqrt 9.0) @result{} 3.0\n"
+ "(sqrt -9.0) @result{} 0.0+3.0i\n"
+ "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
+ "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
+ "@end example")
+#define FUNC_NAME s_scm_sqrt
+{
+ if (SCM_COMPLEXP (x))
+ {
+#if HAVE_COMPLEX_DOUBLE && HAVE_USABLE_CSQRT
+ return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (x)));
+#else
+ double re = SCM_COMPLEX_REAL (x);
+ double im = SCM_COMPLEX_IMAG (x);
+ return scm_c_make_polar (sqrt (hypot (re, im)),
+ 0.5 * atan2 (im, re));
+#endif
+ }
+ else
+ {
+ double xx = scm_to_double (x);
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, sqrt (-xx));
+ else
+ return scm_from_double (sqrt (xx));
+ }
+}
+#undef FUNC_NAME
+
+
+
void
scm_init_numbers ()
{
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 40b836959..8448b7fd2 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -263,6 +263,10 @@ SCM_API SCM scm_angle (SCM z);
SCM_API SCM scm_exact_to_inexact (SCM z);
SCM_API SCM scm_inexact_to_exact (SCM z);
SCM_API SCM scm_trunc (SCM x);
+SCM_API SCM scm_log (SCM z);
+SCM_API SCM scm_log10 (SCM z);
+SCM_API SCM scm_exp (SCM z);
+SCM_API SCM scm_sqrt (SCM z);
/* bignum internal functions */
SCM_API SCM scm_i_mkbig (void);
diff --git a/libguile/ports.c b/libguile/ports.c
index bcf4a89f1..3fcc0efaa 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -27,12 +27,14 @@
#include <stdio.h>
#include <errno.h>
+#include <fcntl.h> /* for chsize on mingw */
#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/eval.h"
+#include "libguile/fports.h" /* direct access for seek and truncate */
#include "libguile/objects.h"
#include "libguile/goops.h"
#include "libguile/smob.h"
@@ -64,9 +66,17 @@
#include <sys/ioctl.h>
#endif
-#ifdef __MINGW32__
-#include <fcntl.h>
+/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
+ already, but have this code here in case that wasn't so in past versions,
+ or perhaps to help other minimal DOS environments.
+
+ gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
+ might be possibilities if we've got other systems without ftruncate. */
+
+#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
#define ftruncate(fd, size) chsize (fd, size)
+#undef HAVE_FTRUNCATE
+#define HAVE_FTRUNCATE 1
#endif
@@ -1456,7 +1466,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
SCM_OUT_OF_RANGE (3, whence);
- if (SCM_OPPORTP (fd_port))
+ if (SCM_OPFPORTP (fd_port))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ return scm_i_fport_seek (fd_port, offset, how);
+ }
+ else if (SCM_OPPORTP (fd_port))
{
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
off_t off = scm_to_off_t (offset);
@@ -1481,28 +1496,48 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
}
#undef FUNC_NAME
-#ifdef __MINGW32__
-/* Define this function since it is not supported under Windows. */
-static int truncate (char *file, int length)
+#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)
{
- int ret = -1, fdes;
- if ((fdes = open (file, O_BINARY | O_WRONLY)) != -1)
+ int ret, fdes;
+
+ fdes = open (file, O_BINARY | O_WRONLY);
+ if (fdes == -1)
+ return -1;
+
+ ret = ftruncate (fdes, length);
+ if (ret == -1)
{
- ret = chsize (fdes, length);
+ int save_errno = errno;
close (fdes);
+ errno = save_errno;
+ return -1;
}
- return ret;
+
+ return close (fdes);
}
-#endif /* __MINGW32__ */
+#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
(SCM object, SCM length),
- "Truncates the object referred to by @var{object} to at most\n"
- "@var{length} bytes. @var{object} can be a string containing a\n"
- "file name or an integer file descriptor or a port.\n"
- "@var{length} may be omitted if @var{object} is not a file name,\n"
- "in which case the truncation occurs at the current port\n"
- "position. The return value is unspecified.")
+ "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 rv;
@@ -1529,6 +1564,11 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
c_length));
}
+ else if (SCM_OPOUTFPORTP (object))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ rv = scm_i_fport_truncate (object, length);
+ }
else if (SCM_OPOUTPORTP (object))
{
off_t c_length = scm_to_off_t (length);
diff --git a/libguile/posix.c b/libguile/posix.c
index 136d77084..8129c6413 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -40,7 +40,7 @@
#include "libguile/validate.h"
#include "libguile/posix.h"
-#include "libguile/i18n.h"
+#include "libguile/gettext.h"
#include "libguile/threads.h"
@@ -115,6 +115,10 @@ extern char ** environ;
#include <locale.h>
#endif
+#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
+# define USE_GNU_LOCALE_API
+#endif
+
#if HAVE_CRYPT_H
# include <crypt.h>
#endif
@@ -157,6 +161,12 @@ extern char ** environ;
#define F_OK 0
#endif
+/* No prototype for this on Solaris 10. The man page says it's in
+ <unistd.h> ... but it lies. */
+#if ! HAVE_DECL_SETHOSTNAME
+int sethostname (char *name, size_t namelen);
+#endif
+
/* On NextStep, <utime.h> doesn't define struct utime, unless we
#define _POSIX_SOURCE before #including it. I think this is less
of a kludge than defining struct utimbuf ourselves. */
@@ -943,7 +953,12 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
- execv (exec_file, exec_argv);
+ execv (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
SCM_SYSERROR;
/* not reached. */
@@ -974,7 +989,12 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
- execvp (exec_file, exec_argv);
+ execvp (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
SCM_SYSERROR;
/* not reached. */
@@ -1013,7 +1033,17 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
scm_dynwind_unwind_handler (free_string_pointers, exec_env,
SCM_F_WIND_EXPLICITLY);
- execve (exec_file, exec_argv, exec_env);
+ execve (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_env);
SCM_SYSERROR;
/* not reached. */
@@ -1354,7 +1384,15 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
}
#undef FUNC_NAME
+#ifndef USE_GNU_LOCALE_API
+/* This mutex is used to serialize invocations of `setlocale ()' on non-GNU
+ systems (i.e., systems where a reentrant locale API is not available).
+ See `i18n.c' for details. */
+scm_i_pthread_mutex_t scm_i_locale_mutex;
+#endif
+
#ifdef HAVE_SETLOCALE
+
SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
(SCM category, SCM locale),
"If @var{locale} is omitted, return the current value of the\n"
@@ -1383,7 +1421,14 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
scm_dynwind_free (clocale);
}
+#ifndef USE_GNU_LOCALE_API
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+#endif
rv = setlocale (scm_i_to_lc_category (category, 1), clocale);
+#ifndef USE_GNU_LOCALE_API
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+#endif
+
if (rv == NULL)
{
/* POSIX and C99 don't say anything about setlocale setting errno, so
@@ -1917,9 +1962,13 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
#endif /* HAVE_GETHOSTNAME */
-void
+void
scm_init_posix ()
{
+#ifndef USE_GNU_LOCALE_API
+ scm_i_pthread_mutex_init (&scm_i_locale_mutex, NULL);
+#endif
+
scm_add_feature ("posix");
#ifdef HAVE_GETEUID
scm_add_feature ("EIDs");
diff --git a/libguile/posix.h b/libguile/posix.h
index 3bef9f96d..871bba850 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -23,8 +23,7 @@
#include "libguile/__scm.h"
-
-
+#include "libguile/threads.h"
@@ -87,6 +86,8 @@ SCM_API SCM scm_sethostname (SCM name);
SCM_API SCM scm_gethostname (void);
SCM_API void scm_init_posix (void);
+SCM_API scm_i_pthread_mutex_t scm_i_locale_mutex;
+
#endif /* SCM_POSIX_H */
/*
diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h
index 64b56e197..5f652252a 100644
--- a/libguile/pthread-threads.h
+++ b/libguile/pthread-threads.h
@@ -69,8 +69,12 @@ extern pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
/* Onces
*/
#define scm_i_pthread_once_t pthread_once_t
-#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT
#define scm_i_pthread_once pthread_once
+#if SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT
+#define SCM_I_PTHREAD_ONCE_INIT { PTHREAD_ONCE_INIT }
+#else
+#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT
+#endif
/* Thread specific storage
*/
diff --git a/libguile/script.c b/libguile/script.c
index 33fcbc130..e3425e108 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -381,7 +381,9 @@ scm_shell_usage (int fatal, char *message)
" -v, --version display version information and exit\n"
" \\ read arguments from following script lines\n"
"\n"
- "Please report bugs to bug-guile@gnu.org\n",
+ "Please report bugs to bug-guile@gnu.org. (Note that you must\n"
+ "be subscribed to this list first, in order to successfully send\n"
+ "a report to it).\n",
scm_usage_name);
if (fatal)
diff --git a/libguile/socket.c b/libguile/socket.c
index a9b7ed8ca..5d09c615b 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -98,9 +98,7 @@ SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0,
"and returned as a new integer.")
#define FUNC_NAME s_scm_htonl
{
- scm_t_uint32 c_in = SCM_NUM2ULONG (1, value);
-
- return scm_from_ulong (htonl (c_in));
+ return scm_from_ulong (htonl (scm_to_uint32 (value)));
}
#undef FUNC_NAME
@@ -111,9 +109,7 @@ SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0,
"and returned as a new integer.")
#define FUNC_NAME s_scm_ntohl
{
- scm_t_uint32 c_in = SCM_NUM2ULONG (1, value);
-
- return scm_from_ulong (ntohl (c_in));
+ return scm_from_ulong (ntohl (scm_to_uint32 (value)));
}
#undef FUNC_NAME
@@ -1459,25 +1455,34 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0,
SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
(SCM sock, SCM str, SCM flags, SCM start, SCM end),
- "Return data from the socket port @var{sock} and also\n"
- "information about where the data was received from.\n"
- "@var{sock} must already be bound to the address from which\n"
- "data is to be received. @code{str}, is a string into which the\n"
- "data will be written. The size of @var{str} limits the amount\n"
- "of data which can be received: in the case of packet protocols,\n"
- "if a packet larger than this limit is encountered then some\n"
- "data will be irrevocably lost.\n\n"
- "The optional @var{flags} argument is a value or bitwise OR of\n"
- "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n"
- "The value returned is a pair: the @emph{car} is the number of\n"
- "bytes read from the socket and the @emph{cdr} an address object\n"
- "in the same form as returned by @code{accept}. The address\n"
- "will given as @code{#f} if not available, as is usually the\n"
- "case for stream sockets.\n\n"
- "The @var{start} and @var{end} arguments specify a substring of\n"
- "@var{str} to which the data should be written.\n\n"
- "Note that the data is read directly from the socket file\n"
- "descriptor: any unread buffered port data is ignored.")
+ "Receive data from socket port @var{sock} (which must be already\n"
+ "bound), returning the originating address as well as the data.\n"
+ "This is usually for use on datagram sockets, but can be used on\n"
+ "stream-oriented sockets too.\n"
+ "\n"
+ "The data received is stored in the given @var{str}, using\n"
+ "either the whole string or just the region between the optional\n"
+ "@var{start} and @var{end} positions. The size of @var{str}\n"
+ "limits the amount of data which can be received. For datagram\n"
+ "protocols, if a packet larger than this is received then excess\n"
+ "bytes are irrevocably lost.\n"
+ "\n"
+ "The return value is a pair. The @code{car} is the number of\n"
+ "bytes read. The @code{cdr} is a socket address object which is\n"
+ "where the data come from, or @code{#f} if the origin is\n"
+ "unknown.\n"
+ "\n"
+ "The optional @var{flags} argument is a or bitwise OR\n"
+ "(@code{logior}) of @code{MSG_OOB}, @code{MSG_PEEK},\n"
+ "@code{MSG_DONTROUTE} etc.\n"
+ "\n"
+ "Data is read directly from the socket file descriptor, any\n"
+ "buffered port data is ignored.\n"
+ "\n"
+ "On a GNU/Linux system @code{recvfrom!} is not multi-threading,\n"
+ "all threads stop while a @code{recvfrom!} call is in progress.\n"
+ "An application may need to use @code{select}, @code{O_NONBLOCK}\n"
+ "or @code{MSG_DONTWAIT} to avoid this.")
#define FUNC_NAME s_scm_recvfrom
{
int rv;
@@ -1728,6 +1733,9 @@ scm_init_socket ()
#endif
/* recv/send options. */
+#ifdef MSG_DONTWAIT
+ scm_c_define ("MSG_DONTWAIT", scm_from_int (MSG_DONTWAIT));
+#endif
#ifdef MSG_OOB
scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB));
#endif
diff --git a/libguile/stime.c b/libguile/stime.c
index 37d2290cf..418e80f21 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -497,8 +497,10 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6));
lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7));
lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8));
+#if HAVE_STRUCT_TM_TM_GMTOFF
+ lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9));
+#endif
#ifdef HAVE_TM_ZONE
- lt->tm_gmtoff = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9));
if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10)))
lt->tm_zone = NULL;
else
@@ -731,6 +733,7 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
{
struct tm t;
const char *fmt, *str, *rest;
+ long zoff;
SCM_VALIDATE_STRING (1, format);
SCM_VALIDATE_STRING (2, string);
@@ -748,6 +751,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
tm_init (tm_year);
tm_init (tm_wday);
tm_init (tm_yday);
+#if HAVE_STRUCT_TM_TM_GMTOFF
+ tm_init (tm_gmtoff);
+#endif
#undef tm_init
/* GNU glibc strptime() "%s" is affected by the current timezone, since it
@@ -766,7 +772,15 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
SCM_SYSERROR;
}
- return scm_cons (filltime (&t, 0, NULL),
+ /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
+ available */
+#if HAVE_STRUCT_TM_TM_GMTOFF
+ zoff = - t.tm_gmtoff; /* seconds west, not east */
+#else
+ zoff = 0;
+#endif
+
+ return scm_cons (filltime (&t, zoff, NULL),
scm_from_signed_integer (rest - str));
}
#undef FUNC_NAME
diff --git a/libguile/threads.c b/libguile/threads.c
index 5f5218019..d15046bd2 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -28,6 +28,11 @@
#endif
#include <stdio.h>
#include <assert.h>
+
+#ifdef HAVE_STRING_H
+#include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
+#endif
+
#if HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
@@ -558,7 +563,8 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
}
#if SCM_USE_PTHREAD_THREADS
-#ifdef HAVE_PTHREAD_ATTR_GETSTACK
+/* pthread_getattr_np not available on MacOS X and Solaris 10. */
+#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
#define HAVE_GET_THREAD_STACK_BASE
@@ -592,7 +598,7 @@ get_thread_stack_base ()
}
}
-#endif /* HAVE_PTHREAD_ATTR_GETSTACK */
+#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */
#else /* !SCM_USE_PTHREAD_THREADS */
@@ -1276,8 +1282,8 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1,
scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
/ sizeof (SCM_STACKITEM))); \
- bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
- top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
+ bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \
+ top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
scm_mark_locations (bot, top - bot); } while (0)
#else
# define SCM_MARK_BACKING_STORE()
diff --git a/libguile/unif.c b/libguile/unif.c
index 8594ba3da..d3bf82314 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -1150,10 +1150,10 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
{
- size_t k = SCM_I_ARRAY_NDIM (v);
+ size_t k, ndim = SCM_I_ARRAY_NDIM (v);
scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v);
- while (k > 0)
+ for (k = 0; k < ndim; k++)
{
long ind;
@@ -1161,9 +1161,8 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
SCM_WRONG_NUM_ARGS ();
ind = scm_to_long (SCM_CAR (args));
args = SCM_CDR (args);
- k -= 1;
- if (ind < s->lbnd || ind > s->ubnd)
+ if (ind < s[k].lbnd || ind > s[k].ubnd)
{
res = SCM_BOOL_F;
/* We do not stop the checking after finding a violation
@@ -2661,7 +2660,7 @@ read_decimal_integer (SCM port, int c, ssize_t *resp)
}
if (got_it)
- *resp = res;
+ *resp = sign * res;
return c;
}
@@ -2745,6 +2744,11 @@ scm_i_read_array (SCM port, int c)
{
c = scm_getc (port);
c = read_decimal_integer (port, c, &len);
+ if (len < 0)
+ scm_i_input_error (NULL, port,
+ "array length must be non-negative",
+ SCM_EOL);
+
s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
}
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 4bc5ce611..c3107ecf1 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -476,15 +476,15 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
SCM res = SCM_EOL;
const SCM *data;
scm_t_array_handle handle;
- size_t i, len;
+ size_t i, count, len;
ssize_t inc;
data = scm_vector_elements (v, &handle, &len, &inc);
- for (i = len*inc; i > 0;)
- {
- i -= inc;
- res = scm_cons (data[i], res);
- }
+ for (i = (len - 1) * inc, count = 0;
+ count < len;
+ i -= inc, count++)
+ res = scm_cons (data[i], res);
+
scm_array_handle_release (&handle);
return res;
}