diff options
Diffstat (limited to 'libguile')
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; } |