mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Merge commit '0329137392' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	libguile/gc.c
	libguile/srcprop.c
	libguile/srcprop.h
This commit is contained in:
Ludovic Courtès 2008-09-10 22:33:40 +02:00
commit 4a4849dbe0
87 changed files with 6963 additions and 3486 deletions
Download patch file Download diff file Expand all files Collapse all files

65
.gitignore vendored Normal file
View file

@ -0,0 +1,65 @@
*.o
*.info
*.info-[0-9]*
version.texi
Makefile
Makefile.in
.deps
.libs
autom4te.cache
config.sub
config.guess
config.status
config.log
config.h
guile-readline-config.h
*.doc
*.x
*.lo
*.la
aclocal.m4
libtool
ltmain.sh
configure
depcomp
elisp-comp
missing
mdate-sh
install-sh
texinfo.tex
*~
BUGS
Makefile
Makefile.in
aclocal.m4
autom4te.cache
benchmark-guile
check-guile
check-guile.log
compile
confdefs.h
config.build-subdirs
config.cache
config.guess
config.h
config.h.in
config.log
config.status
config.sub
configure
conftest
conftest.c
depcomp
elisp-comp
guile-*.tar.gz
guile-tools
install-sh
libtool
ltconfig
ltmain.sh
mdate-sh
missing
mkinstalldirs
pre-inst-guile
pre-inst-guile-env
stamp-h1

1459
ABOUT-NLS
View file

File diff suppressed because it is too large Load diff

74
ChangeLog
View file

@ -1,3 +1,77 @@
2007-02-18 Neil Jerram <neil@ossau.uklinux.net>
* acinclude.m4 (AM_INTL_SUBDIR): Remove unnecessary dnl.
* configure.in: Remove AM_GNU_GETTEXT_VERSION again.
* Makefile.am (EXTRA_DIST): Add config.rpath.
* config.rpath (Module): New (from gettext package).
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* configure.in: Look for `langinfo.h', `nl_types.h', `xlocale.h'
and `nl_langinfo'.
2007-01-28 Neil Jerram <neil@ossau.uklinux.net>
* configure.in: Do AM_GNU_GETTEXT_VERSION, so that autoreconf will
run autopoint.
* acinclude.m4 (AM_INTL_SUBDIR): Provide dummy definition, to work
around current autoconf/automake/gettext bug.
* INSTALL: New upstream version.
* ABOUT-NLS: New upstream version.
2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org>
* .gitignore: new file. Make using git easier.
2007-01-03 Han-Wen Nienhuys <hanwen@lilypond.org>
* autogen.sh (Module): only try to run render-bugs if it exists.
2006-12-27 Kevin Ryde <user42@zip.com.au>
* configure.in (pthread_get_stackaddr_np, pthread_sigmask): New tests.
2006-12-24 Han-Wen Nienhuys <hanwen@lilypond.org>
* autogen.sh (mscripts): only execute render-bugs if it exists.
2006-12-23 Kevin Ryde <user42@zip.com.au>
* configure.in (-lm): No need to suppress libm on mingw, it's not
needed because it's empty, but including it does no harm.
(-lm): Look for "cos" instead of "main", since cos and friends are the
purpose of looking for libm.
(winsock etc): Test $host = *-*-mingw* rather than $MINGW32, autoconf
regards the latter as obsolete.
(AC_MINGW32): Remove test, $MINGW32 now unused.
(uint32_t): Look at HAVE_NETDB_H rather than hard-coding __MINGW32__
in the test program.
2006-12-15 Kevin Ryde <user42@zip.com.au>
* configure.in (process.h, pipe, _pipe): New checks.
2006-12-14 Kevin Ryde <user42@zip.com.au>
* configure.in (struct timespec, pthread.h): Look for struct timespec
in <pthread.h> as well as <time.h>, it's in pthread.h on mingw.
Reported by Nils Durner.
2006-12-03 Kevin Ryde <user42@zip.com.au>
* Makefile.am (AUTOMAKE_OPTIONS): Bump to automake 1.10 required, so
that config.rpath from gettext will go into the dist (and give an
error if not).
* configure.in (AM_PROG_CC_C_O): New macro, needed by automake 1.10
for per-target cflags in libguile/Makefile.am.
2006-11-18 Ludovic Courtès <ludovic.courtes@laas.fr>
* GUILE-VERSION: Added `LIBGUILE_I18N_*'.

50
INSTALL
View file

@ -1,8 +1,8 @@
Installation Instructions
*************************
Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005 Free
Software Foundation, Inc.
Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005,
2006 Free Software Foundation, Inc.
This file is free documentation; the Free Software Foundation gives
unlimited permission to copy, distribute and modify it.
@ -10,7 +10,10 @@ unlimited permission to copy, distribute and modify it.
Basic Installation
==================
These are generic installation instructions.
Briefly, the shell commands `./configure; make; make install' should
configure, build, and install this package. The following
more-detailed instructions are generic; see the `README' file for
instructions specific to this package.
The `configure' shell script attempts to guess correct values for
various system-dependent variables used during compilation. It uses
@ -23,9 +26,9 @@ debugging `configure').
It can also use an optional file (typically called `config.cache'
and enabled with `--cache-file=config.cache' or simply `-C') that saves
the results of its tests to speed up reconfiguring. (Caching is
the results of its tests to speed up reconfiguring. Caching is
disabled by default to prevent problems with accidental use of stale
cache files.)
cache files.
If you need to do unusual things to compile the package, please try
to figure out how `configure' could check whether to do them, and mail
@ -35,20 +38,17 @@ some point `config.cache' contains results you don't want to keep, you
may remove or edit it.
The file `configure.ac' (or `configure.in') is used to create
`configure' by a program called `autoconf'. You only need
`configure.ac' if you want to change it or regenerate `configure' using
a newer version of `autoconf'.
`configure' by a program called `autoconf'. You need `configure.ac' if
you want to change it or regenerate `configure' using a newer version
of `autoconf'.
The simplest way to compile this package is:
1. `cd' to the directory containing the package's source code and type
`./configure' to configure the package for your system. If you're
using `csh' on an old version of System V, you might need to type
`sh ./configure' instead to prevent `csh' from trying to execute
`configure' itself.
`./configure' to configure the package for your system.
Running `configure' takes awhile. While running, it prints some
messages telling which features it is checking for.
Running `configure' might take a while. While running, it prints
some messages telling which features it is checking for.
2. Type `make' to compile the package.
@ -78,7 +78,7 @@ details on some of the pertinent environment variables.
by setting variables in the command line or in the environment. Here
is an example:
./configure CC=c89 CFLAGS=-O2 LIBS=-lposix
./configure CC=c99 CFLAGS=-g LIBS=-lposix
*Note Defining Variables::, for more details.
@ -87,17 +87,15 @@ Compiling For Multiple Architectures
You can compile the package for more than one kind of computer at the
same time, by placing the object files for each architecture in their
own directory. To do this, you must use a version of `make' that
supports the `VPATH' variable, such as GNU `make'. `cd' to the
own directory. To do this, you can use GNU `make'. `cd' to the
directory where you want the object files and executables to go and run
the `configure' script. `configure' automatically checks for the
source code in the directory that `configure' is in and in `..'.
If you have to use a `make' that does not support the `VPATH'
variable, you have to compile the package for one architecture at a
time in the source code directory. After you have installed the
package for one architecture, use `make distclean' before reconfiguring
for another architecture.
With a non-GNU `make', it is safer to compile the package for one
architecture at a time in the source code directory. After you have
installed the package for one architecture, use `make distclean' before
reconfiguring for another architecture.
Installation Names
==================
@ -190,12 +188,12 @@ them in the `configure' command line, using `VAR=value'. For example:
./configure CC=/usr/local2/bin/gcc
causes the specified `gcc' to be used as the C compiler (unless it is
overridden in the site shell script). Here is a another example:
overridden in the site shell script).
/bin/bash ./configure CONFIG_SHELL=/bin/bash
Unfortunately, this technique does not work for `CONFIG_SHELL' due to
an Autoconf bug. Until the bug is fixed you can use this workaround:
Here the `CONFIG_SHELL=/bin/bash' operand causes subsequent
configuration-related scripts to be executed by `/bin/bash'.
CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash
`configure' Invocation
======================

7
Makefile.am
View file

@ -19,7 +19,10 @@
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = 1.5
# want automake 1.10 or higher so that AM_GNU_GETTEXT can tell automake that
# config.rpath is needed
#
AUTOMAKE_OPTIONS = 1.10
SUBDIRS = oop libguile ice-9 guile-config guile-readline emacs \
scripts srfi doc examples test-suite benchmark-suite lang am
@ -30,7 +33,7 @@ include_HEADERS = libguile.h
# automake sometimes forgets to distribute acconfig.h,
# apparently depending on the phase of the moon.
EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS
EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS config.rpath
TESTS = check-guile

35
NEWS
View file

@ -19,7 +19,40 @@ Changes in 1.9.XXXXXXXX:
* Changes to the distribution
* Changes to the stand-alone interpreter
* Changes to Scheme functions and syntax
* Changes to the C interface
** A new 'memoize-symbol evaluator trap has been added. This trap can
be used for efficiently implementing a Scheme code coverage.
* Changes to the C interface
** Functions for handling scm_option now no longer require an argument
indicating length of the scm_t_option array.
Changes in 1.8.2 (since 1.8.1):
* New procedures (see the manual for details)
** set-program-arguments
* Bugs fixed
** Fractions were not `equal?' if stored in unreduced form.
(A subtle problem, since printing a value reduced it, making it work.)
** srfi-60 `copy-bit' failed on 64-bit systems
** "guile --use-srfi" option at the REPL can replace core functions
(Programs run with that option were ok, but in the interactive REPL
the core bindings got priority, preventing SRFI replacements or
extensions.)
** `regexp-exec' doesn't abort() on #\nul in the input or bad flags arg
** `kill' on mingw throws an error for a pid other than oneself
** Procedure names are attached to procedure-with-setters
** Array read syntax works with negative lower bound
** `array-in-bounds?' fix if an array has different lower bounds on each index
** `*' returns exact 0 for "(* inexact 0)"
This follows what it always did for "(* 0 inexact)".
** Build problems on Solaris fixed
** Build problems on Mingw fixed
Changes in 1.8.1 (since 1.8.0):

2
acinclude.m4
View file

@ -308,3 +308,5 @@ else
fi
AC_LANG_RESTORE
])dnl ACX_PTHREAD
AC_DEFUN([AM_INTL_SUBDIR], [])

6
autogen.sh
View file

@ -31,8 +31,10 @@ ln -s $workbook/build/dist-files/.gdbinit examples/example.gdbinit
# TODO: This should be moved to dist-guile
mscripts=../guile-scripts
rm -f BUGS
$mscripts/render-bugs > BUGS
if test -x $mscripts/render-bugs ; then
rm -f BUGS
$mscripts/render-bugs > BUGS
fi
######################################################################
### update infrastructure

614
config.rpath Executable file
View file

@ -0,0 +1,614 @@
#! /bin/sh
# Output a system dependent set of variables, describing how to set the
# run time search path of shared libraries in an executable.
#
# Copyright 1996-2006 Free Software Foundation, Inc.
# Taken from GNU libtool, 2001
# Originally by Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
#
# This file is free software; the Free Software Foundation gives
# unlimited permission to copy and/or distribute it, with or without
# modifications, as long as this notice is preserved.
#
# The first argument passed to this file is the canonical host specification,
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
# or
# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
# The environment variables CC, GCC, LDFLAGS, LD, with_gnu_ld
# should be set by the caller.
#
# The set of defined variables is at the end of this script.
# Known limitations:
# - On IRIX 6.5 with CC="cc", the run time search patch must not be longer
# than 256 bytes, otherwise the compiler driver will dump core. The only
# known workaround is to choose shorter directory names for the build
# directory and/or the installation directory.
# All known linkers require a `.a' archive for static linking (except MSVC,
# which needs '.lib').
libext=a
shrext=.so
host="$1"
host_cpu=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
host_vendor=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
host_os=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
# Code taken from libtool.m4's _LT_CC_BASENAME.
for cc_temp in $CC""; do
case $cc_temp in
compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
\-*) ;;
*) break;;
esac
done
cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'`
# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC.
wl=
if test "$GCC" = yes; then
wl='-Wl,'
else
case "$host_os" in
aix*)
wl='-Wl,'
;;
darwin*)
case $cc_basename in
xlc*)
wl='-Wl,'
;;
esac
;;
mingw* | pw32* | os2*)
;;
hpux9* | hpux10* | hpux11*)
wl='-Wl,'
;;
irix5* | irix6* | nonstopux*)
wl='-Wl,'
;;
newsos6)
;;
linux*)
case $cc_basename in
icc* | ecc*)
wl='-Wl,'
;;
pgcc | pgf77 | pgf90)
wl='-Wl,'
;;
ccc*)
wl='-Wl,'
;;
como)
wl='-lopt='
;;
*)
case `$CC -V 2>&1 | sed 5q` in
*Sun\ C*)
wl='-Wl,'
;;
esac
;;
esac
;;
osf3* | osf4* | osf5*)
wl='-Wl,'
;;
sco3.2v5*)
;;
solaris*)
wl='-Wl,'
;;
sunos4*)
wl='-Qoption ld '
;;
sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*)
wl='-Wl,'
;;
sysv4*MP*)
;;
unicos*)
wl='-Wl,'
;;
uts4*)
;;
esac
fi
# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS.
hardcode_libdir_flag_spec=
hardcode_libdir_separator=
hardcode_direct=no
hardcode_minus_L=no
case "$host_os" in
cygwin* | mingw* | pw32*)
# FIXME: the MSVC++ port hasn't been tested in a loooong time
# When not using gcc, we currently assume that we are using
# Microsoft Visual C++.
if test "$GCC" != yes; then
with_gnu_ld=no
fi
;;
interix*)
# we just hope/assume this is gcc and not c89 (= MSVC++)
with_gnu_ld=yes
;;
openbsd*)
with_gnu_ld=no
;;
esac
ld_shlibs=yes
if test "$with_gnu_ld" = yes; then
# Set some defaults for GNU ld with shared library support. These
# are reset later if shared libraries are not supported. Putting them
# here allows them to be overridden if necessary.
# Unlike libtool, we use -rpath here, not --rpath, since the documented
# option of GNU ld is called -rpath, not --rpath.
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
case "$host_os" in
aix3* | aix4* | aix5*)
# On AIX/PPC, the GNU linker is very broken
if test "$host_cpu" != ia64; then
ld_shlibs=no
fi
;;
amigaos*)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_minus_L=yes
# Samuel A. Falvo II <kc5tja@dolphin.openprojects.net> reports
# that the semantics of dynamic libraries on AmigaOS, at least up
# to version 4, is to share data among multiple programs linked
# with the same dynamic library. Since this doesn't match the
# behavior of shared libraries on other platforms, we cannot use
# them.
ld_shlibs=no
;;
beos*)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
cygwin* | mingw* | pw32*)
# hardcode_libdir_flag_spec is actually meaningless, as there is
# no search path for DLLs.
hardcode_libdir_flag_spec='-L$libdir'
if $LD --help 2>&1 | grep 'auto-import' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
interix3*)
hardcode_direct=no
hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
;;
linux*)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
netbsd*)
;;
solaris*)
if $LD -v 2>&1 | grep 'BFD 2\.8' > /dev/null; then
ld_shlibs=no
elif $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
case `$LD -v 2>&1` in
*\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
ld_shlibs=no
;;
*)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-rpath,$libdir`'
else
ld_shlibs=no
fi
;;
esac
;;
sunos4*)
hardcode_direct=yes
;;
*)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
esac
if test "$ld_shlibs" = no; then
hardcode_libdir_flag_spec=
fi
else
case "$host_os" in
aix3*)
# Note: this linker hardcodes the directories in LIBPATH if there
# are no directories specified by -L.
hardcode_minus_L=yes
if test "$GCC" = yes; then
# Neither direct hardcoding nor static linking is supported with a
# broken collect2.
hardcode_direct=unsupported
fi
;;
aix4* | aix5*)
if test "$host_cpu" = ia64; then
# On IA64, the linker does run time linking by default, so we don't
# have to do anything special.
aix_use_runtimelinking=no
else
aix_use_runtimelinking=no
# Test if we are trying to use run time linking or normal
# AIX style linking. If -brtl is somewhere in LDFLAGS, we
# need to do runtime linking.
case $host_os in aix4.[23]|aix4.[23].*|aix5*)
for ld_flag in $LDFLAGS; do
if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
aix_use_runtimelinking=yes
break
fi
done
;;
esac
fi
hardcode_direct=yes
hardcode_libdir_separator=':'
if test "$GCC" = yes; then
case $host_os in aix4.[012]|aix4.[012].*)
collect2name=`${CC} -print-prog-name=collect2`
if test -f "$collect2name" && \
strings "$collect2name" | grep resolve_lib_name >/dev/null
then
# We have reworked collect2
hardcode_direct=yes
else
# We have old collect2
hardcode_direct=unsupported
hardcode_minus_L=yes
hardcode_libdir_flag_spec='-L$libdir'
hardcode_libdir_separator=
fi
;;
esac
fi
# Begin _LT_AC_SYS_LIBPATH_AIX.
echo 'int main () { return 0; }' > conftest.c
${CC} ${LDFLAGS} conftest.c -o conftest
aix_libpath=`dump -H conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
}'`
if test -z "$aix_libpath"; then
aix_libpath=`dump -HX64 conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
}'`
fi
if test -z "$aix_libpath"; then
aix_libpath="/usr/lib:/lib"
fi
rm -f conftest.c conftest
# End _LT_AC_SYS_LIBPATH_AIX.
if test "$aix_use_runtimelinking" = yes; then
hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
else
if test "$host_cpu" = ia64; then
hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib'
else
hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
fi
fi
;;
amigaos*)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_minus_L=yes
# see comment about different semantics on the GNU ld section
ld_shlibs=no
;;
bsdi[45]*)
;;
cygwin* | mingw* | pw32*)
# When not using gcc, we currently assume that we are using
# Microsoft Visual C++.
# hardcode_libdir_flag_spec is actually meaningless, as there is
# no search path for DLLs.
hardcode_libdir_flag_spec=' '
libext=lib
;;
darwin* | rhapsody*)
hardcode_direct=no
if test "$GCC" = yes ; then
:
else
case $cc_basename in
xlc*)
;;
*)
ld_shlibs=no
;;
esac
fi
;;
dgux*)
hardcode_libdir_flag_spec='-L$libdir'
;;
freebsd1*)
ld_shlibs=no
;;
freebsd2.2*)
hardcode_libdir_flag_spec='-R$libdir'
hardcode_direct=yes
;;
freebsd2*)
hardcode_direct=yes
hardcode_minus_L=yes
;;
freebsd* | kfreebsd*-gnu | dragonfly*)
hardcode_libdir_flag_spec='-R$libdir'
hardcode_direct=yes
;;
hpux9*)
hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
hardcode_libdir_separator=:
hardcode_direct=yes
# hardcode_minus_L: Not really in the search PATH,
# but as the default location of the library.
hardcode_minus_L=yes
;;
hpux10*)
if test "$with_gnu_ld" = no; then
hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
hardcode_libdir_separator=:
hardcode_direct=yes
# hardcode_minus_L: Not really in the search PATH,
# but as the default location of the library.
hardcode_minus_L=yes
fi
;;
hpux11*)
if test "$with_gnu_ld" = no; then
hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
hardcode_libdir_separator=:
case $host_cpu in
hppa*64*|ia64*)
hardcode_direct=no
;;
*)
hardcode_direct=yes
# hardcode_minus_L: Not really in the search PATH,
# but as the default location of the library.
hardcode_minus_L=yes
;;
esac
fi
;;
irix5* | irix6* | nonstopux*)
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
hardcode_libdir_separator=:
;;
netbsd*)
hardcode_libdir_flag_spec='-R$libdir'
hardcode_direct=yes
;;
newsos6)
hardcode_direct=yes
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
hardcode_libdir_separator=:
;;
openbsd*)
hardcode_direct=yes
if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
else
case "$host_os" in
openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
hardcode_libdir_flag_spec='-R$libdir'
;;
*)
hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
;;
esac
fi
;;
os2*)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_minus_L=yes
;;
osf3*)
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
hardcode_libdir_separator=:
;;
osf4* | osf5*)
if test "$GCC" = yes; then
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
else
# Both cc and cxx compiler support -rpath directly
hardcode_libdir_flag_spec='-rpath $libdir'
fi
hardcode_libdir_separator=:
;;
solaris*)
hardcode_libdir_flag_spec='-R$libdir'
;;
sunos4*)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_direct=yes
hardcode_minus_L=yes
;;
sysv4)
case $host_vendor in
sni)
hardcode_direct=yes # is this really true???
;;
siemens)
hardcode_direct=no
;;
motorola)
hardcode_direct=no #Motorola manual says yes, but my tests say they lie
;;
esac
;;
sysv4.3*)
;;
sysv4*MP*)
if test -d /usr/nec; then
ld_shlibs=yes
fi
;;
sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7*)
;;
sysv5* | sco3.2v5* | sco5v6*)
hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-R,$libdir`'
hardcode_libdir_separator=':'
;;
uts4*)
hardcode_libdir_flag_spec='-L$libdir'
;;
*)
ld_shlibs=no
;;
esac
fi
# Check dynamic linker characteristics
# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER.
libname_spec='lib$name'
case "$host_os" in
aix3*)
;;
aix4* | aix5*)
;;
amigaos*)
;;
beos*)
;;
bsdi[45]*)
;;
cygwin* | mingw* | pw32*)
shrext=.dll
;;
darwin* | rhapsody*)
shrext=.dylib
;;
dgux*)
;;
freebsd1*)
;;
kfreebsd*-gnu)
;;
freebsd* | dragonfly*)
;;
gnu*)
;;
hpux9* | hpux10* | hpux11*)
case $host_cpu in
ia64*)
shrext=.so
;;
hppa*64*)
shrext=.sl
;;
*)
shrext=.sl
;;
esac
;;
interix3*)
;;
irix5* | irix6* | nonstopux*)
case "$host_os" in
irix5* | nonstopux*)
libsuff= shlibsuff=
;;
*)
case $LD in
*-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= ;;
*-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 ;;
*-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 ;;
*) libsuff= shlibsuff= ;;
esac
;;
esac
;;
linux*oldld* | linux*aout* | linux*coff*)
;;
linux*)
;;
knetbsd*-gnu)
;;
netbsd*)
;;
newsos6)
;;
nto-qnx*)
;;
openbsd*)
;;
os2*)
libname_spec='$name'
shrext=.dll
;;
osf3* | osf4* | osf5*)
;;
solaris*)
;;
sunos4*)
;;
sysv4 | sysv4.3*)
;;
sysv4*MP*)
;;
sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
;;
uts4*)
;;
esac
sed_quote_subst='s/\(["`$\\]\)/\\\1/g'
escaped_wl=`echo "X$wl" | sed -e 's/^X//' -e "$sed_quote_subst"`
shlibext=`echo "$shrext" | sed -e 's,^\.,,'`
escaped_hardcode_libdir_flag_spec=`echo "X$hardcode_libdir_flag_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
LC_ALL=C sed -e 's/^\([a-zA-Z0-9_]*\)=/acl_cv_\1=/' <<EOF
# How to pass a linker flag through the compiler.
wl="$escaped_wl"
# Static library suffix (normally "a").
libext="$libext"
# Shared library suffix (normally "so").
shlibext="$shlibext"
# Flag to hardcode \$libdir into a binary during linking.
# This must work even if \$libdir does not exist.
hardcode_libdir_flag_spec="$escaped_hardcode_libdir_flag_spec"
# Whether we need a single -rpath flag with a separated argument.
hardcode_libdir_separator="$hardcode_libdir_separator"
# Set to yes if using DIR/libNAME.so during linking hardcodes DIR into the
# resulting binary.
hardcode_direct="$hardcode_direct"
# Set to yes if using the -LDIR flag during linking hardcodes DIR into the
# resulting binary.
hardcode_minus_L="$hardcode_minus_L"
EOF

53
configure.in
View file

@ -29,7 +29,7 @@ AC_PREREQ(2.53)
AC_INIT(m4_esyscmd(. ./GUILE-VERSION && echo -n ${PACKAGE}),
m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION}),
[bug-guile@gnu.org])
[bug-guile@gnu.org])
AC_CONFIG_AUX_DIR([.])
AC_CONFIG_SRCDIR(GUILE-VERSION)
AM_INIT_AUTOMAKE([no-define])
@ -55,7 +55,6 @@ AC_CONFIG_SUBDIRS(guile-readline)
dnl Some more checks for Win32
AC_CYGWIN
AC_MINGW32
AC_LIBTOOL_WIN32_DLL
AC_PROG_INSTALL
@ -68,6 +67,8 @@ AC_ISC_POSIX
AC_MINIX
AM_PROG_CC_STDC
# for per-target cflags in the libguile subdir
AM_PROG_CC_C_O
AC_LIBTOOL_DLOPEN
AC_PROG_LIBTOOL
@ -528,12 +529,14 @@ AC_HEADER_SYS_WAIT
# Reasons for testing:
# complex.h - new in C99
# fenv.h - available in C99, but not older systems
# process.h - mingw specific
# langinfo.h, nl_types.h - SuS v2
#
AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h string.h \
AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h process.h string.h \
regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
direct.h])
direct.h langinfo.h nl_types.h])
# "complex double" is new in C99, and "complex" is only a keyword if
# <complex.h> is included
@ -560,9 +563,11 @@ AC_TYPE_GETGROUPS
AC_TYPE_SIGNAL
AC_TYPE_MODE_T
if test $MINGW32 = no; then
AC_CHECK_LIB(m, main)
fi
# On mingw -lm is empty, so this test is unnecessary, but it's
# harmless so we don't hard-code to suppress it.
#
AC_CHECK_LIB(m, cos)
AC_CHECK_FUNCS(gethostbyname)
if test $ac_cv_func_gethostbyname = no; then
AC_CHECK_LIB(nsl, gethostbyname)
@ -577,7 +582,8 @@ dnl
dnl Check for Winsock and other functionality on Win32 (*not* CygWin)
dnl
EXTRA_DEFS=""
if test "$MINGW32" = "yes" ; then
case $host in
*-*-mingw*)
AC_CHECK_HEADER(winsock2.h, [AC_DEFINE([HAVE_WINSOCK2_H], 1,
[Define if you have the <winsock2.h> header file.])])
AC_CHECK_LIB(ws2_32, main)
@ -591,7 +597,8 @@ if test "$MINGW32" = "yes" ; then
AC_DEFINE(USE_DLL_IMPORT, 1,
[Define if you need additional CPP macros on Win32 platforms.])
fi
fi
;;
esac
AC_SUBST(EXTRA_DEFS)
# Reasons for testing:
@ -610,23 +617,29 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# has it as an inline for chsize)
# ioctl - not in mingw.
# gmtime_r - recent posix, not on old systems
# pipe - not in mingw
# _pipe - specific to mingw, taking 3 args
# readdir_r - recent posix, not on old systems
# stat64 - SuS largefile stuff, not on old systems
# sysconf - not on old systems
# truncate - not in mingw
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale - GNU extensions (glibc)
# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
# nl_langinfo - X/Open, not available on Windows.
#
AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale])
AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo])
# Reasons for testing:
# netdb.h - not in mingw
# sys/param.h - not in mingw
# pthread.h - only available with pthreads. ACX_PTHREAD doesn't
# check this specifically, we need it for the timespec test below.
# sethostname - the function itself check because it's not in mingw,
# the DECL is checked because Solaris 10 doens't have in any header
# xlocale.h - needed on Darwin for the `locale_t' API
#
AC_CHECK_HEADERS(crypt.h netdb.h sys/param.h sys/resource.h sys/file.h)
AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h xlocale.h)
AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname)
AC_CHECK_DECLS([sethostname])
@ -794,7 +807,7 @@ AC_CACHE_VAL(guile_cv_have_uint32_t,
#if HAVE_STDINT_H
#include <stdint.h>
#endif
#ifndef __MINGW32__
#ifndef HAVE_NETDB_H
#include <netdb.h>
#endif],
[uint32_t a;],
@ -1047,17 +1060,22 @@ if test $scm_cv_struct_linger = yes; then
fi
# On mingw, struct timespec is in <pthread.h>.
#
AC_MSG_CHECKING(for struct timespec)
AC_CACHE_VAL(scm_cv_struct_timespec,
AC_TRY_COMPILE([
#include <time.h>],
#include <time.h>
#if HAVE_PTHREAD_H
#include <pthread.h>
#endif],
[struct timespec t; t.tv_nsec = 100],
scm_cv_struct_timespec="yes",
scm_cv_struct_timespec="no"))
AC_MSG_RESULT($scm_cv_struct_timespec)
if test $scm_cv_struct_timespec = yes; then
AC_DEFINE(HAVE_STRUCT_TIMESPEC, 1,
[Define this if your system defines struct timespec via <time.h>.])
[Define this if your system defines struct timespec via either <time.h> or <pthread.h>.])
fi
#--------------------------------------------------------------------
@ -1091,8 +1109,11 @@ case "$with_threads" in
# Reasons for testing:
# pthread_getattr_np - "np" meaning "non portable" says it
# all; not present on MacOS X or Solaris 10
# pthread_get_stackaddr_np - "np" meaning "non portable" says it
# all; specific to MacOS X
# pthread_sigmask - not available on mingw
#
AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np)
AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_sigmask)
# On past versions of Solaris, believe 8 through 10 at least, you
# had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };".

52
doc/ref/ChangeLog
View file

@ -1,3 +1,55 @@
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* api-data.texi (Conversion): Made cross refs point to `Number
Input and Output' rather than `The ice-9 i18n Module'.
(String Comparison): Likewise for `Text Collation'.
* api-i18n.texi (Internationalization): Re-organized the whole
section, documented new i18n features. Added the following
subsections: `i18n Introduction', `Text Collation', `Character
Case Mapping', `Number Input and Output', `Accessing Locale
Information'. Removed `The ice-9 i18n Module'.
* posix.texi (Locales): Updated cross-ref formerly pointing to
`The ice-9 i18n Module'.
* srfi-modules.texi (SRFI-19 String to date): Mention the
internationalization of `string->date'.
2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org>
* api-options.texi (Evaluator trap options): document
memoize-symbol-handler
* api-evaluation.texi (Evaluator Behaviour): link to the Evaluator
trap options node in trap-enable/trap-set! doco.
2007-01-16 Kevin Ryde <user42@zip.com.au>
* api-data.texi (Mapping Folding and Unfolding): In string-unfold,
ssay make_final default is nothing extra. The `(lambda (x) )' shown
was not quite right, it would have been `(lambda (x) "")' if anything.
* api-init.texi (Initialization): Cross reference Runtime Environment
for scm_set_program_arguments.
* posix.texi (Runtime Environment): Expand program-arguments
description, add set-program-arguments, add scm_set_program_arguments,
note args are per-thread.
2006-12-14 Kevin Ryde <user42@zip.com.au>
* api-procedures.texi (let-keywords Reference): Expand variously to
make it clear what's actually taken and done. Shortfalls reported by
Han-Wen Nienhuys.
2006-12-13 Kevin Ryde <user42@zip.com.au>
* api-control.texi (Handling Errors): Cross reference "Error
Reporting" for `scm-error', not just "above".
* posix.texi (Encryption): Cross reference crypt in the glibc manual.
Clarify that key and salt are strings.
* srfi-modules.texi (SRFI-17): Expand variously.
2006-11-18 Ludovic Courtès <ludovic.courtes@laas.fr>
* Makefile.am (BUILT_SOURCES): New variable.

2
doc/ref/api-control.texi
View file

@ -1476,7 +1476,7 @@ In the following C functions, @var{SUBR} and @var{MESSAGE} parameters
can be @code{NULL} to give the effect of @code{#f} described above.
@deftypefn {C Function} SCM scm_error (SCM @var{key}, char *@var{subr}, char *@var{message}, SCM @var{args}, SCM @var{rest})
Throw an error, as per @code{scm-error} above.
Throw an error, as per @code{scm-error} (@pxref{Error Reporting}).
@end deftypefn
@deftypefn {C Function} void scm_syserror (char *@var{subr})

8
doc/ref/api-data.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -1015,7 +1015,7 @@ zero.
The following procedures read and write numbers according to their
external representation as defined by R5RS (@pxref{Lexical structure,
R5RS Lexical Structure,, r5rs, The Revised^5 Report on the Algorithmic
Language Scheme}). @xref{The ice-9 i18n Module, the @code{(ice-9
Language Scheme}). @xref{Number Input and Output, the @code{(ice-9
i18n)} module}, for locale-dependent number parsing.
@deffn {Scheme Procedure} number->string n [radix]
@ -2949,7 +2949,7 @@ predicates (@pxref{Characters}), but are defined on character sequences.
The first set is specified in R5RS and has names that end in @code{?}.
The second set is specified in SRFI-13 and the names have no ending
@code{?}. The predicates ending in @code{-ci} ignore the character case
when comparing strings. @xref{The ice-9 i18n Module, the @code{(ice-9
when comparing strings. @xref{Text Collation, the @code{(ice-9
i18n)} module}, for locale-dependent string comparison.
@rnindex string=?
@ -3525,7 +3525,7 @@ string.
@item @var{make_final} is applied to the terminal seed
value (on which @var{p} returns true) to produce
the final/rightmost portion of the constructed string.
It defaults to @code{(lambda (x) )}.
The default is nothing extra.
@end itemize
@end deffn

23
doc/ref/api-debug.texi
View file

@ -615,14 +615,21 @@ Invoke the Guile debugger to explore the context of the last error.
@cindex Low level trap calls
@cindex Evaluator trap calls
Guile's evaluator can be configured to call three user-specified
procedures at various points in its operation: an
@dfn{apply-frame-handler} procedure, an @dfn{enter-frame-handler}
procedure, and an @dfn{exit-frame-handler} procedure. These procedures,
and the circumstances under which the evaluator calls them, are
configured by the ``evaluator trap options'' interface (@pxref{Evaluator
trap options}), and by the @code{trace} and @code{breakpoints} fields of
the ``debug options'' interface (@pxref{Debugger options}).
Guile's evaluator can be configured to call the following four user-specified
procedures at various points in its operation.
@table @dfn
@item apply-frame-handler
@item enter-frame-handler
@item exit-frame-handler
@item memoize-symbol-handler
@end table
These procedures, and the circumstances under which the evaluator
calls them, are configured by the ``evaluator trap options'' interface
(@pxref{Evaluator trap options}), and by the @code{trace} and
@code{breakpoints} fields of the ``debug options'' interface
(@pxref{Debugger options}).
It is not necessary to understand the fine details of these low level
calls, and of the options which configure them, in order to use the

3
doc/ref/api-evaluation.texi
View file

@ -629,6 +629,9 @@ Like @code{help}, but also print programmer options.
Modify the evaluator options. @code{trap-enable} should be used with boolean
options and switches them on, @code{trap-disable} switches them off.
@code{trap-set!} can be used to set an option to a specific value.
See @ref{Evaluator trap options} for more information on the available
trap handlers.
@end deffn
@deffn {Scheme Procedure} evaluator-traps-interface [setting]

441
doc/ref/api-i18n.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -11,24 +11,29 @@
@cindex internationalization
@cindex i18n
Guile provides internationalization support for Scheme programs in two
ways. First, procedures to manipulate text and data in a way that
conforms to particular cultural conventions (i.e., in a
``locale-dependent'' way) are provided in the @code{(ice-9 i18n)}.
Second, Guile allows the use of GNU @code{gettext} to translate
program message strings.
Guile provides internationalization@footnote{For concision and style,
programmers often like to refer to internationalization as ``i18n''.}
support for Scheme programs in two ways. First, procedures to
manipulate text and data in a way that conforms to particular cultural
conventions (i.e., in a ``locale-dependent'' way) are provided in the
@code{(ice-9 i18n)}. Second, Guile allows the use of GNU
@code{gettext} to translate program message strings.
@menu
* The ice-9 i18n Module:: Honoring cultural conventions.
* Gettext Support:: Translating message strings.
* i18n Introduction:: Introduction to Guile's i18n support.
* Text Collation:: Sorting strings and characters.
* Character Case Mapping:: Case mapping.
* Number Input and Output:: Parsing and printing numbers.
* Accessing Locale Information:: Detailed locale information.
* Gettext Support:: Translating message strings.
@end menu
@node The ice-9 i18n Module
@subsection The @code{(ice-9 i18n)} Module
@node i18n Introduction, Text Collation, Internationalization, Internationalization
@subsection Internationalization with Guile
In order to make use of the following functions, one must import the
@code{(ice-9 i18n)} module in the usual way:
In order to make use of the functions described thereafter, the
@code{(ice-9 i18n)} module must be imported in the usual way:
@example
(use-modules (ice-9 i18n))
@ -64,83 +69,41 @@ the user is defined by the @code{LC_MESSAGES} category
The procedures provided by this module allow the development of
programs that adapt automatically to any locale setting. As we will
see later, many of the locale-dependent procedures provided by this
module can optionally take a @dfn{locale object} argument. This
additional argument defines the locale settings that must be followed
by the invoked procedure. When it is omitted, then the current locale
settings of the process are followed (@pxref{Locales,
@code{setlocale}}).
see later, many of these procedures can optionally take a @dfn{locale
object} argument. This additional argument defines the locale
settings that must be followed by the invoked procedure. When it is
omitted, then the current locale settings of the process are followed
(@pxref{Locales, @code{setlocale}}).
The following procedures allow the manipulation of such locale
objects.
@deffn {Scheme Procedure} make-locale category-mask locale-name [base-locale]
@deffnx {C Function} scm_make_locale (category_mask, locale_name, base_locale)
@deffn {Scheme Procedure} make-locale category-list locale-name [base-locale]
@deffnx {C Function} scm_make_locale (category_list, locale_name, base_locale)
Return a reference to a data structure representing a set of locale
datasets. @var{locale-name} should be a string denoting a particular
locale, e.g., @code{"aa_DJ"}. 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. The optional @var{base-locale} argument can be used to specify
a locale object whose settings are to be used as a basis for the
locale object being returned.
locale (e.g., @code{"aa_DJ"}) and @var{category-list} should be either
a list of locale categories or a single category as used with
@code{setlocale} (@pxref{Locales, @code{setlocale}}). Optionally, if
@code{base-locale} is passed, it should be a locale object denoting
settings for categories not listed in @var{category-list}.
The available locale category masks are the following:
@defvar LC_COLLATE_MASK
Represents the collation locale category.
@end defvar
@defvar LC_CTYPE_MASK
Represents the character classification locale category.
@end defvar
@defvar LC_MESSAGES_MASK
Represents the messages locale category.
@end defvar
@defvar LC_MONETARY_MASK
Represents the monetary locale category.
@end defvar
@defvar LC_NUMERIC_MASK
Represents the way numbers are displayed.
@end defvar
@defvar LC_TIME_MASK
Represents the way date and time are displayed
@end defvar
The following category masks are also available but will not have any
effect on systems that do not support them:
@defvar LC_PAPER_MASK
@defvarx LC_NAME_MASK
@defvarx LC_ADDRESS_MASK
@defvarx LC_TELEPHONE_MASK
@defvarx LC_MEASUREMENT_MASK
@defvarx LC_IDENTIFICATION_MASK
@end defvar
Finally, there is also:
@defvar LC_ALL_MASK
This represents all the locale categories supported by the system.
@end defvar
The @code{LC_*_MASK} variables are bound to integers which may be OR'd
together using @code{logior} (@pxref{Primitive Numerics,
@code{logior}}). For instance, the following invocation creates a
locale object that combines the use of Esperanto for messages and
character classification with the default settings for the other
categories (i.e., the settings of the default @code{C} locale which
usually represents conventions in use in the USA):
The following invocation creates a locale object that combines the use
of Swedish for messages and character classification with the
default settings for the other categories (i.e., the settings of the
default @code{C} locale which usually represents conventions in use in
the USA):
@example
(make-locale (logior LC_MESSAGE_MASK LC_CTYPE_MASK) "eo_EO")
(make-locale (list LC_MESSAGE LC_CTYPE) "sv_SE")
@end example
The following example combines the use of Swedish conventions with
monetary conventions from Croatia:
The following example combines the use of Esperanto messages and
conventions with monetary conventions from Croatia:
@example
(make-locale LC_MONETARY_MASK "hr_HR"
(make-locale LC_ALL_MASK "sv_SE"))
(make-locale LC_MONETARY "hr_HR"
(make-locale LC_ALL "eo_EO"))
@end example
A @code{system-error} exception (@pxref{Handling Errors}) is raised by
@ -155,70 +118,56 @@ error may be raised later, when the locale object is actually used.
Return true if @var{obj} is a locale object.
@end deffn
The following procedures provide support for text collation.
@defvr {Scheme Variable} %global-locale
@defvrx {C Variable} scm_global_locale
This variable is bound to a locale object denoting the current process
locale as installed using @code{setlocale ()} (@pxref{Locales}). It
may be used like any other locale object, including as a third
argument to @code{make-locale}, for instance.
@end defvr
@node Text Collation, Character Case Mapping, i18n Introduction, Internationalization
@subsection Text Collation
The following procedures provide support for text collation, i.e.,
locale-dependent string and character sorting.
@deffn {Scheme Procedure} string-locale<? s1 s2 [locale]
@deffnx {C Function} scm_string_locale_lt (s1, s2, 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.
@end deffn
@deffn {Scheme Procedure} string-locale>? s1 s2 [locale]
@deffnx {Scheme Procedure} string-locale>? s1 s2 [locale]
@deffnx {C Function} scm_string_locale_gt (s1, s2, locale)
@deffnx {Scheme Procedure} string-locale-ci<? s1 s2 [locale]
@deffnx {C Function} scm_string_locale_ci_lt (s1, s2, locale)
@deffnx {Scheme Procedure} string-locale-ci>? s1 s2 [locale]
@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, 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.
@end deffn
@deffn {Scheme Procedure} string-locale-ci<? s1 s2 [locale]
@deffnx {C Function} scm_string_locale_ci_lt (s1, s2, 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.
@end deffn
@deffn {Scheme Procedure} string-locale-ci>? s1 s2 [locale]
@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, 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.
otherwise, the current system locale is used. For the @code{-ci}
variants, the comparison is made in a case-insensitive way.
@end deffn
@deffn {Scheme Procedure} string-locale-ci=? s1 s2 [locale]
@deffnx {C Function} scm_string_locale_ci_eq (s1, s2, 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
a locale object (as returned by @code{make-locale}) and will be used to
perform the comparison; otherwise, the current system locale is used.
@end deffn
@deffn {Scheme Procedure} char-locale<? c1 c2 [locale]
@deffnx {C Function} scm_char_locale_lt (c1, c2, locale)
Return true if character @var{c1} is lower than @var{c2} according to
@var{locale} or to the current locale.
@end deffn
@deffn {Scheme Procedure} char-locale>? c1 c2 [locale]
@deffnx {Scheme Procedure} char-locale>? c1 c2 [locale]
@deffnx {C Function} scm_char_locale_gt (c1, c2, locale)
Return true if character @var{c1} is greater than @var{c2} according
to @var{locale} or to the current locale.
@end deffn
@deffn {Scheme Procedure} char-locale-ci<? c1 c2 [locale]
@deffnx {Scheme Procedure} char-locale-ci<? c1 c2 [locale]
@deffnx {C Function} scm_char_locale_ci_lt (c1, c2, 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.
@end deffn
@deffn {Scheme Procedure} char-locale-ci>? c1 c2 [locale]
@deffnx {Scheme Procedure} char-locale-ci>? c1 c2 [locale]
@deffnx {C Function} scm_char_locale_ci_gt (c1, c2, 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.
Compare characters @var{c1} and @var{c2} according to either
@var{locale} (a locale object as returned by @code{make-locale}) or
the current locale. For the @code{-ci} variants, the comparison is
made in a case-insensitive way.
@end deffn
@deffn {Scheme Procedure} char-locale-ci=? c1 c2 [locale]
@ -227,6 +176,9 @@ 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.
@end deffn
@node Character Case Mapping, Number Input and Output, Text Collation, Internationalization
@subsection Character Case Mapping
The procedures below provide support for ``character case mapping'',
i.e., to convert characters or strings to their upper-case or
lower-case equivalent. Note that SRFI-13 provides procedures that
@ -236,8 +188,8 @@ account specificities of the customs in use in a particular language
or region of the world. For instance, while most languages using the
Latin alphabet map lower-case letter ``i'' to upper-case letter ``I'',
Turkish maps lower-case ``i'' to ``Latin capital letter I with dot
above''. The following procedures allow to provide idiomatic
character mapping.
above''. The following procedures allow programmers to provide
idiomatic character mapping.
@deffn {Scheme Procedure} char-locale-downcase chr [locale]
@deffnx {C Function} scm_char_locale_upcase (chr, locale)
@ -263,12 +215,20 @@ Return a new string that is the down-case version of @var{str}
according to either @var{locale} or the current locale.
@end deffn
Finally, the following procedures allow programs to read numbers
Note that in the current implementation Guile has no notion of
multibyte characters and in a multibyte locale characters may not be
converted correctly.
@node Number Input and Output, Accessing Locale Information, Character Case Mapping, Internationalization
@subsection Number Input and Output
The following procedures allow programs to read and write numbers
written according to a particular locale. As an example, in English,
``ten thousand and a half'' is usually written @code{10,000.5} while
in French it is written @code{10000,5}. These procedures allow to
account for these differences.
in French it is written @code{10 000,5}. These procedures allow such
differences to be taken into account.
@findex strtod
@deffn {Scheme Procedure} locale-string->integer str [base [locale]]
@deffnx {C Function} scm_locale_string_to_integer (str, base, locale)
Convert string @var{str} into an integer according to either
@ -276,22 +236,239 @@ Convert string @var{str} into an integer according to either
the current process locale. If @var{base} is specified, then it
determines the base of the integer being read (e.g., @code{16} for an
hexadecimal number, @code{10} for a decimal number); by default,
decimal numbers are read. Return two values: an integer (on success)
or @code{#f}, and the number of characters read from @var{str}
(@code{0} on failure).
decimal numbers are read. Return two values (@pxref{Multiple
Values}): an integer (on success) or @code{#f}, and the number of
characters read from @var{str} (@code{0} on failure).
This function is based on the C library's @code{strtol} function
(@pxref{Parsing of Integers, @code{strtol},, libc, The GNU C Library
Reference Manual}).
@end deffn
@findex strtod
@deffn {Scheme Procedure} locale-string->inexact str [locale]
@deffnx {C Function} scm_locale_string_to_inexact (str, 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).
the current process locale. Return two values (@pxref{Multiple
Values}): an inexact number (on success) or @code{#f}, and the number
of characters read from @var{str} (@code{0} on failure).
This function is based on the C library's @code{strtod} function
(@pxref{Parsing of Floats, @code{strtod},, libc, The GNU C Library
Reference Manual}).
@end deffn
@deffn {Scheme Procedure} number->locale-string number [fraction-digits [locale]]
Convert @var{number} (an inexact) into a string according to the
cultural conventions of either @var{locale} (a locale object) or the
current locale. Optionally, @var{fraction-digits} may be bound to an
integer specifying the number of fractional digits to be displayed.
@end deffn
@deffn {Scheme Procedure} monetary-amount->locale-string amount intl? [locale]
Convert @var{amount} (an inexact denoting a monetary amount) into a
string according to the cultural conventions of either @var{locale} (a
locale object) or the current locale. If @var{intl?} is true, then
the international monetary format for the given locale is used
(@pxref{Currency Symbol, international and locale monetary formats,,
libc, The GNU C Library Reference Manual}).
@end deffn
@node Gettext Support
@node Accessing Locale Information, Gettext Support, Number Input and Output, Internationalization
@subsection Accessing Locale Information
@findex nl_langinfo
@cindex low-level locale information
It is sometimes useful to obtain very specific information about a
locale such as the word it uses for days or months, its format for
representing floating-point figures, etc. The @code{(ice-9 i18n)}
module provides support for this in a way that is similar to the libc
functions @code{nl_langinfo ()} and @code{localeconv ()}
(@pxref{Locale Information, accessing locale information from C,,
libc, The GNU C Library Reference Manual}). The available functions
are listed below.
@deffn {Scheme Procedure} locale-encoding [locale]
Return the name of the encoding (a string whose interpretation is
system-dependent) of either @var{locale} or the current locale.
@end deffn
The following functions deal with dates and times.
@deffn {Scheme Procedure} locale-day day [locale]
@deffnx {Scheme Procedure} locale-day-short day [locale]
@deffnx {Scheme Procedure} locale-month month [locale]
@deffnx {Scheme Procedure} locale-month-short month [locale]
Return the word (a string) used in either @var{locale} or the current
locale to name the day (or month) denoted by @var{day} (or
@var{month}), an integer between 1 and 7 (or 1 and 12). The
@code{-short} variants provide an abbreviation instead of a full name.
@end deffn
@deffn {Scheme Procedure} locale-am-string [locale]
@deffnx {Scheme Procedure} locale-pm-string [locale]
Return a (potentially empty) string that is used to denote @i{ante
meridiem} (or @i{post meridiem}) hours in 12-hour format.
@end deffn
@deffn {Scheme Procedure} locale-date+time-format [locale]
@deffnx {Scheme Procedure} locale-date-format [locale]
@deffnx {Scheme Procedure} locale-time-format [locale]
@deffnx {Scheme Procedure} locale-time+am/pm-format [locale]
@deffnx {Scheme Procedure} locale-era-date-format [locale]
@deffnx {Scheme Procedure} locale-era-date+time-format [locale]
@deffnx {Scheme Procedure} locale-era-time-format [locale]
These procedures return format strings suitable to @code{strftime}
(@pxref{Time}) that may be used to display (part of) a date/time
according to certain constraints and to the conventions of either
@var{locale} or the current locale (@pxref{The Elegant and Fast Way,
the @code{nl_langinfo ()} items,, libc, The GNU C Library Reference
Manual}).
@end deffn
@deffn {Scheme Procedure} locale-era [locale]
@deffnx {Scheme Procedure} locale-era-year [locale]
These functions return, respectively, the era and the year of the
relevant era used in @var{locale} or the current locale. Most locales
do not define this value. In this case, the empty string is returned.
An example of a locale that does define this value is the Japanese
one.
@end deffn
The following procedures give information about number representation.
@deffn {Scheme Procedure} locale-decimal-point [locale]
@deffnx {Scheme Procedure} locale-thousands-separator [locale]
These functions return a string denoting the representation of the
decimal point or that of the thousand separator (respectively) for
either @var{locale} or the current locale.
@end deffn
@deffn {Scheme Procedure} locale-digit-grouping [locale]
Return a (potentially circular) list of integers denoting how digits
of the integer part of a number are to be grouped, starting at the
decimal point and going to the left. The list contains integers
indicating the size of the successive groups, from right to left. If
the list is non-circular, then no grouping occurs for digits beyond
the last group.
For instance, if the returned list is a circular list that contains
only @code{3} and the thousand separator is @code{","} (as is the case
with English locales), then the number @code{12345678} should be
printed @code{12,345,678}.
@end deffn
The following procedures deal with the representation of monetary
amounts. Some of them take an additional @var{intl?} argument (a
boolean) that tells whether the international or local monetary
conventions for the given locale are to be used.
@deffn {Scheme Procedure} locale-monetary-decimal-point [locale]
@deffnx {Scheme Procedure} locale-monetary-thousands-separator [locale]
@deffnx {Scheme Procedure} locale-monetary-grouping [locale]
These are the monetary counterparts of the above procedures. These
procedures apply to monetary amounts.
@end deffn
@deffn {Scheme Procedure} locale-currency-symbol intl? [locale]
Return the currency symbol (a string) of either @var{locale} or the
current locale.
The following example illustrates the difference between the local and
international monetary formats:
@example
(define us (make-locale LC_MONETARY "en_US"))
(locale-currency-symbol #f us)
@result{} "-$"
(locale-currency-symbol #t us)
@result{} "USD "
@end example
@end deffn
@deffn {Scheme Procedure} locale-monetary-fractional-digits intl? [locale]
Return the number of fractional digits to be used when printing
monetary amounts according to either @var{locale} or the current
locale. If the locale does not specify it, then @code{#f} is
returned.
@end deffn
@deffn {Scheme Procedure} locale-currency-symbol-precedes-positive? intl? [locale]
@deffnx {Scheme Procedure} locale-currency-symbol-precedes-negative? intl? [locale]
@deffnx {Scheme Procedure} locale-positive-separated-by-space? intl? [locale]
@deffnx {Scheme Procedure} locale-negative-separated-by-space? intl? [locale]
These procedures return a boolean indicating whether the currency
symbol should precede a positive/negative number, and whether a
whitespace should be inserted between the currency symbol and a
positive/negative amount.
@end deffn
@deffn {Scheme Procedure} locale-monetary-positive-sign [locale]
@deffnx {Scheme Procedure} locale-monetary-negative-sign [locale]
Return a string denoting the positive (respectively negative) sign
that should be used when printing a monetary amount.
@end deffn
@deffn {Scheme Procedure} locale-positive-sign-position
@deffnx {Scheme Procedure} locale-negative-sign-position
These functions return a symbol telling where a sign of a
positive/negative monetary amount is to appear when printing it. The
possible values are:
@table @code
@item parenthesize
The currency symbol and quantity should be surrounded by parentheses.
@item sign-before
Print the sign string before the quantity and currency symbol.
@item sign-after
Print the sign string after the quantity and currency symbol.
@item sign-before-currency-symbol
Print the sign string right before the currency symbol.
@item sign-after-currency-symbol
Print the sign string right after the currency symbol.
@item unspecified
Unspecified. We recommend you print the sign after the currency
symbol.
@end table
@end deffn
Finally, the two following procedures may be helpful when programming
user interfaces:
@deffn {Scheme Procedure} locale-yes-regexp [locale]
@deffnx {Scheme Procedure} locale-no-regexp [locale]
Return a string that can be used as a regular expression to recognize
a positive (respectively, negative) response to a yes/no question.
For the C locale, the default values are typically @code{"^[yY]"} and
@code{"^[nN]"}, respectively.
Here is an example:
@example
(format #t "Does Guile rock?~%")
(let ((answer (read-line)))
(cond ((string-match (locale-yes-regexp) answer)
"Yes it does.")
((string-match (locale-no-regexp) answer)
"No it doesn't.")
(else
"What do you mean?")))
@end example
For an internationalized yes/no string output, @code{gettext} should
be used (@pxref{Gettext Support}).
@end deffn
Example uses of some of these functions are the implementation of the
@code{number->locale-string} and @code{monetary-amount->locale-string}
procedures (@pxref{Number Input and Output}), as well as that the
SRFI-19 date and time convertion to/from strings (@pxref{SRFI-19}).
@node Gettext Support, , Accessing Locale Information, Internationalization
@subsection Gettext Support
Guile provides an interface to GNU @code{gettext} for translating

6
doc/ref/api-init.texi
View file

@ -1,12 +1,13 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Initialization
@section Initializing Guile
@cindex Initializing Guile
Each thread that wants to use functions from the Guile API needs to
put itself into guile mode with either @code{scm_with_guile} or
@ -93,7 +94,8 @@ The function @code{scm_boot_guile} arranges for the Scheme
@code{command-line} function to return the strings given by @var{argc}
and @var{argv}. If @var{main_func} modifies @var{argc} or @var{argv},
it should call @code{scm_set_program_arguments} with the final list, so
Scheme code will know which arguments have been processed.
Scheme code will know which arguments have been processed
(@pxref{Runtime Environment}).
@end deftypefn
@deftypefn {C Function} void scm_shell (int @var{argc}, char **@var{argv})

15
doc/ref/api-options.texi
View file

@ -554,6 +554,7 @@ Here is the list of evaluator trap options generated by typing
exit-frame no Trap when exiting eval or apply.
apply-frame no Trap when entering apply.
enter-frame no Trap when eval enters new frame.
memoize-symbol no Trap when eval memoizes a symbol's value
traps yes Enable evaluator traps.
@end smallexample
@ -612,6 +613,20 @@ way.
@var{retval} is the return value.
@end deffn
@deffn memoize-symbol-handler key cont expression env
Called when the evaluator memoizes the value of a procedure symbol
@var{cont} is a ``debug object'', which means that it can be passed to
@code{make-stack} to discover the stack at the point of the trap. The
exit frame handler's code can capture a restartable continuation if it
wants to by using @code{call-with-current-continuation} in the usual
way.
@var{retval} is the return value.
@end deffn
@node Debugger options
@subsubsection Debugger options

82
doc/ref/api-procedures.texi
View file

@ -198,30 +198,72 @@ evaluated in order.
@node let-keywords Reference
@subsubsection let-keywords Reference
@c FIXME::martin: Review me!
@code{let-keywords} and @code{let-keywords*} extract values from
keyword style argument lists, binding local variables to those values
or to defaults.
@code{let-keywords} and @code{let-keywords*} are used for extracting
values from argument lists which use keywords instead of argument
position for binding local variables to argument values.
@deffn {library syntax} let-keywords args allow-other-keys? (binding @dots{}) body @dots{}
@deffnx {library syntax} let-keywords* args allow-other-keys? (binding @dots{}) body @dots{}
@var{args} is evaluated and should give a list of the form
@code{(#:keyword1 value1 #:keyword2 value2 @dots{})}. The
@var{binding}s are variables and default expressions, with the
variables to be set (by name) from the keyword values. The @var{body}
forms are then evaluated and the last is the result. An example will
make the syntax clearest,
@code{let-keywords} binds all variables simultaneously, while
@code{let-keywords*} binds them sequentially, consistent with @code{let}
and @code{let*} (@pxref{Local Bindings}).
@example
(define args '(#:xyzzy "hello" #:foo "world"))
@deffn {library syntax} let-keywords rest-arg allow-other-keys? (binding @dots{}) expr @dots{}
@deffnx {library syntax} let-keywords* rest-arg allow-other-keys? (binding @dots{}) expr @dots{}
These macros pick out keyword arguments from @var{rest-arg}, but do not
modify it. This is consistent at least with Common Lisp, which
duplicates keyword arguments in the rest argument. More explanation of what
keyword arguments in a lambda list look like can be found below in
the documentation for @code{lambda*}
(@pxref{lambda* Reference}). @var{binding}s can have the same form as
for @code{let-optional}. If @var{allow-other-keys?} is false, an error
will be thrown if anything that looks like a keyword argument but does
not match a known keyword parameter will result in an error.
(let-keywords args #t
((foo "default for foo")
(bar (string-append "default" "for" "bar")))
(display foo)
(display ", ")
(display bar))
@print{} world, defaultforbar
@end example
After binding the variables, the expressions @var{expr} @dots{} are
evaluated in order.
The binding for @code{foo} comes from the @code{#:foo} keyword in
@code{args}. But the binding for @code{bar} is the default in the
@code{let-keywords}, since there's no @code{#:bar} in the args.
@var{allow-other-keys?} is evaluated and controls whether unknown
keywords are allowed in the @var{args} list. When true other keys are
ignored (such as @code{#:xyzzy} in the example), when @code{#f} an
error is thrown for anything unknown.
@code{let-keywords} is like @code{let} (@pxref{Local Bindings}) in
that all bindings are made at once, the defaults expressions are
evaluated (if needed) outside the scope of the @code{let-keywords}.
@code{let-keywords*} is like @code{let*}, each binding is made
successively, and the default expressions see the bindings previously
made. This is the style used by @code{lambda*} keywords
(@pxref{lambda* Reference}). For example,
@example
(define args '(#:foo 3))
(let-keywords* args #f
((foo 99)
(bar (+ foo 6)))
(display bar))
@print{} 9
@end example
The expression for each default is only evaluated if it's needed,
ie. if the keyword doesn't appear in @var{args}. So one way to make a
keyword mandatory is to throw an error of some sort as the default.
@example
(define args '(#:start 7 #:finish 13))
(let-keywords* args #t
((start 0)
(stop (error "missing #:stop argument")))
...)
@result{} ERROR: missing #:stop argument
@end example
@end deffn

76
doc/ref/posix.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -1348,15 +1348,72 @@ included but subprocesses are not.
@deffn {Scheme Procedure} program-arguments
@deffnx {Scheme Procedure} command-line
@deffnx {Scheme Procedure} set-program-arguments
@deffnx {C Function} scm_program_arguments ()
@deffnx {C Function} scm_set_program_arguments_scm (lst)
@cindex command line
@cindex program arguments
Return the list of command line arguments passed to Guile, as a list of
strings. The list includes the invoked program name, which is usually
@code{"guile"}, but excludes switches and parameters for command line
options like @code{-e} and @code{-l}.
Get the command line arguments passed to Guile, or set new arguments.
The arguments are a list of strings, the first of which is the invoked
program name. This is just @nicode{"guile"} (or the executable path)
when run interactively, or it's the script name when running a script
with @option{-s} (@pxref{Invoking Guile}).
@example
guile -L /my/extra/dir -s foo.scm abc def
(program-arguments) @result{} ("foo.scm" "abc" "def")
@end example
@code{set-program-arguments} allows a library module or similar to
modify the arguments, for example to strip options it recognises,
leaving the rest for the mainline.
The argument list is held in a fluid, which means it's separate for
each thread. Neither the list nor the strings within it are copied at
any point and normally should not be mutated.
The two names @code{program-arguments} and @code{command-line} are an
historical accident, they both do exactly the same thing. The name
@code{scm_set_program_arguments_scm} has an extra @code{_scm} on the
end to avoid clashing with the C function below.
@end deffn
@deftypefn {C Function} void scm_set_program_arguments (int argc, char **argv, char *first)
@cindex command line
@cindex program arguments
Set the list of command line arguments for @code{program-arguments}
and @code{command-line} above.
@var{argv} is an array of null-terminated strings, as in a C
@code{main} function. @var{argc} is the number of strings in
@var{argv}, or if it's negative then a @code{NULL} entry in @var{argv}
marks its end.
@var{first} is an extra string put at the start of the arguments, or
@code{NULL} for no such extra. This is a convenient way to pass the
program name after advancing @var{argv} to strip option arguments.
@example
@{
char *progname = argv[0];
int i;
for (argv++; argv[0] != NULL && argv[0][0] == '-'; argv++)
@{
/* munch option ... */
@}
/* remaining args for scheme level use */
scm_set_program_arguments (-1, argv, progname);
@}
@end example
This sort of thing is often done at startup under
@code{scm_boot_guile} with any options handled at the C level removed.
The given strings are all copied, so the C data is not accessed again
once @code{scm_set_program_arguments} returns.
@end deftypefn
@deffn {Scheme Procedure} getenv nam
@deffnx {C Function} scm_getenv (nam)
@cindex environment
@ -3162,7 +3219,7 @@ Locales and Internationalization, libc, The GNU C Library Reference
Manual}.
Note that @code{setlocale} affects locale settings for the whole
process. @xref{The ice-9 i18n Module, locale objects and
process. @xref{i18n Introduction, locale objects and
@code{make-locale}}, for a thread-safe alternative.
@end deffn
@ -3174,12 +3231,13 @@ Please note that the procedures in this section are not suited for
strong encryption, they are only interfaces to the well-known and
common system library functions of the same name. They are just as good
(or bad) as the underlying functions, so you should refer to your system
documentation before using them.
documentation before using them (@pxref{crypt,, Encrypting Passwords,
libc, The GNU C Library Reference Manual}).
@deffn {Scheme Procedure} crypt key salt
@deffnx {C Function} scm_crypt (key, salt)
Encrypt @var{key} using @var{salt} as the salt value to the
crypt(3) library call.
Encrypt @var{key}, with the addition of @var{salt} (both strings),
using the @code{crypt} C library call.
@end deffn
Although @code{getpass} is not an encryption procedure per se, it

86
doc/ref/srfi-modules.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -1616,24 +1616,61 @@ applied to zero arguments, yields 1.
@subsection SRFI-17 - Generalized set!
@cindex SRFI-17
This is an implementation of SRFI-17: Generalized set!
This SRFI implements a generalized @code{set!}, allowing some
``referencing'' functions to be used as the target location of a
@code{set!}. This feature is available from
@findex getter-with-setter
It exports the Guile procedure @code{make-procedure-with-setter} under
the SRFI name @code{getter-with-setter} and exports the standard
procedures @code{car}, @code{cdr}, @dots{}, @code{cdddr},
@code{string-ref} and @code{vector-ref} as procedures with setters, as
required by the SRFI.
@example
(use-modules (srfi srfi-17))
@end example
SRFI-17 was heavily criticized during its discussion period but it was
finalized anyway. One issue was its concept of globally associating
setter @dfn{properties} with (procedure) values, which is non-Schemy.
For this reason, this implementation chooses not to provide a way to set
the setter of a procedure. In fact, @code{(set! (setter @var{proc})
@var{setter})} signals an error. The only way to attach a setter to a
procedure is to create a new object (a @dfn{procedure with setter}) via
the @code{getter-with-setter} procedure. This procedure is also
specified in the SRFI. Using it avoids the described problems.
@noindent
For example @code{vector-ref} is extended so that
@example
(set! (vector-ref vec idx) new-value)
@end example
@noindent
is equivalent to
@example
(vector-set! vec idx new-value)
@end example
The idea is that a @code{vector-ref} expression identifies a location,
which may be either fetched or stored. The same form is used for the
location in both cases, encouraging visual clarity. This is similar
to the idea of an ``lvalue'' in C.
The mechanism for this kind of @code{set!} is in the Guile core
(@pxref{Procedures with Setters}). This module adds definitions of
the following functions as procedures with setters, allowing them to
be targets of a @code{set!},
@quotation
@nicode{car}, @nicode{cdr}, @nicode{caar}, @nicode{cadr},
@nicode{cdar}, @nicode{cddr}, @nicode{caaar}, @nicode{caadr},
@nicode{cadar}, @nicode{caddr}, @nicode{cdaar}, @nicode{cdadr},
@nicode{cddar}, @nicode{cdddr}, @nicode{caaaar}, @nicode{caaadr},
@nicode{caadar}, @nicode{caaddr}, @nicode{cadaar}, @nicode{cadadr},
@nicode{caddar}, @nicode{cadddr}, @nicode{cdaaar}, @nicode{cdaadr},
@nicode{cdadar}, @nicode{cdaddr}, @nicode{cddaar}, @nicode{cddadr},
@nicode{cdddar}, @nicode{cddddr}
@nicode{string-ref}, @nicode{vector-ref}
@end quotation
The SRFI specifies @code{setter} (@pxref{Procedures with Setters}) as
a procedure with setter, allowing the setter for a procedure to be
changed, eg.@: @code{(set! (setter foo) my-new-setter-handler)}.
Currently Guile does not implement this, a setter can only be
specified on creation (@code{getter-with-setter} below).
@defun getter-with-setter
The same as the Guile core @code{make-procedure-with-setter}
(@pxref{Procedures with Setters}).
@end defun
@node SRFI-19
@ -2095,10 +2132,10 @@ Conversions @samp{~D}, @samp{~x} and @samp{~X} are not currently
described here, since the specification and reference implementation
differ.
Currently Guile doesn't implement any localizations for the above, all
outputs are in English, and the @samp{~c} conversion is POSIX
@code{ctime} style @samp{~a ~b ~d ~H:~M:~S~z ~Y}. This may change in
the future.
Conversion is locale-dependent on systems that support it
(@pxref{Accessing Locale Information}). @xref{Locales,
@code{setlocale}}, for information on how to change the current
locale.
@node SRFI-19 String to date
@ -2219,9 +2256,10 @@ Notice that the weekday matching forms don't affect the date object
returned, instead the weekday will be derived from the day, month and
year.
Currently Guile doesn't implement any localizations for the above,
month and weekday names are always expected in English. This may
change in the future.
Conversion is locale-dependent on systems that support it
(@pxref{Accessing Locale Information}). @xref{Locales,
@code{setlocale}}, for information on how to change the current
locale.
@end defun

14
emacs/ChangeLog
View file

@ -1,3 +1,17 @@
2007-02-06 Clinton Ebadi <clinton@unknownlamer.org>
* gds-scheme.el (gds-display-results): Use save-selected-window
instead of switching to other-window in order to return to the
proper window in frames with more than two windows.
2007-01-17 Neil Jerram <neil@ossau.uklinux.net>
* gds-scheme.el (gds-display-results): Add another binding for
gds-show-last-stack (RET).
(scheme-mode-map): And another: C-h S.
(scheme-mode-map): And an alternative C-h G binding for
gds-apropos, as we probably should not be using C-h C-g.
2006-11-02 Neil Jerram <neil@ossau.uklinux.net>
* gds-scheme.el (gds-choose-client): Change assq to memq, so that

67
emacs/gds-scheme.el
View file

@ -382,38 +382,39 @@ region's code."
'(nil . "*Guile Evaluation*"))))
(helpp (car helpp+bufname)))
(let ((buf (get-buffer-create (cdr helpp+bufname))))
(save-excursion
(set-buffer buf)
(gds-dissociate-buffer)
(erase-buffer)
(scheme-mode)
(insert (cdr correlator) "\n\n")
(while results
(insert (car results))
(or (bolp) (insert "\\\n"))
(if helpp
nil
(if (cadr results)
(mapcar (function (lambda (value)
(insert " => " value "\n")))
(cadr results))
(insert " => no (or unspecified) value\n"))
(insert "\n"))
(setq results (cddr results)))
(if stack-available
(let ((beg (point))
(map (make-sparse-keymap)))
(define-key map [mouse-1] 'gds-show-last-stack)
(insert "[click here to show error stack]")
(add-text-properties beg (point)
(list 'keymap map
'mouse-face 'highlight))
(insert "\n")))
(goto-char (point-min))
(gds-associate-buffer client))
(pop-to-buffer buf)
(run-hooks 'temp-buffer-show-hook)
(other-window 1))))
(save-selected-window
(save-excursion
(set-buffer buf)
(gds-dissociate-buffer)
(erase-buffer)
(scheme-mode)
(insert (cdr correlator) "\n\n")
(while results
(insert (car results))
(or (bolp) (insert "\\\n"))
(if helpp
nil
(if (cadr results)
(mapcar (function (lambda (value)
(insert " => " value "\n")))
(cadr results))
(insert " => no (or unspecified) value\n"))
(insert "\n"))
(setq results (cddr results)))
(if stack-available
(let ((beg (point))
(map (make-sparse-keymap)))
(define-key map [mouse-1] 'gds-show-last-stack)
(define-key map "\C-m" 'gds-show-last-stack)
(insert "[click here to show error stack]")
(add-text-properties beg (point)
(list 'keymap map
'mouse-face 'highlight))
(insert "\n")))
(goto-char (point-min))
(gds-associate-buffer client))
(pop-to-buffer buf)
(run-hooks 'temp-buffer-show-hook)))))
(defun gds-show-last-stack ()
"Show stack of the most recent error."
@ -1007,6 +1008,8 @@ return the one that they chose."
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
(define-key scheme-mode-map "\C-hG" 'gds-apropos)
(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
(define-key scheme-mode-map "\C-x " 'gds-set-breakpoint)

6
guile-config/ChangeLog
View file

@ -1,3 +1,9 @@
2007-01-04 Kevin Ryde <user42@zip.com.au>
* Makefile.am (guile-config): Use "|" as the sed delimiter, for the
benefit of DOS systems where $(bindir) might include a drive letter
like "c:". Reported by Cesar Strauss.
2006-09-19 Rob Browning <rlb@defaultvalue.org>
* guile-config.in (build-link): Restore the removal of "/usr/lib"

4
guile-config/Makefile.am
View file

@ -1,7 +1,7 @@
## Process this file with Automake to create Makefile.in
## Jim Blandy <jimb@red-bean.com> --- September 1997
##
## Copyright (C) 1998, 1999, 2001, 2006 Free Software Foundation, Inc.
## Copyright (C) 1998, 1999, 2001, 2006, 2007 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -35,7 +35,7 @@ aclocal_DATA = guile.m4
guile-config: guile-config.in ${top_builddir}/libguile/libpath.h
rm -f guile-config.tmp
sed < ${srcdir}/guile-config.in > guile-config.tmp \
-e s:@-bindir-@:${bindir}: \
-e 's|@-bindir-@|${bindir}|' \
-e s:@-GUILE_VERSION-@:${GUILE_VERSION}:
chmod +x guile-config.tmp
mv guile-config.tmp guile-config

5
guile-readline/ChangeLog
View file

@ -1,3 +1,8 @@
2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org>
* readline.c: terminate option list with NULL.
(scm_init_readline): fix CVS mess-up.
2006-10-06 Neil Jerram <neil@ossau.uklinux.net>
* ice-9/readline.scm (new-input-prompt): Renamed from "prompt".

7
guile-readline/readline.c
View file

@ -52,7 +52,8 @@ scm_t_option scm_readline_opts[] = {
{ SCM_OPTION_INTEGER, "history-length", 200,
"History length." },
{ SCM_OPTION_INTEGER, "bounce-parens", 500,
"Time (ms) to show matching opening parenthesis (0 = off)."}
"Time (ms) to show matching opening parenthesis (0 = off)."},
{ 0 }
};
extern void stifle_history (int max);
@ -64,7 +65,6 @@ SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0,
{
SCM ans = scm_options (setting,
scm_readline_opts,
SCM_N_READLINE_OPTIONS,
FUNC_NAME);
stifle_history (SCM_HISTORY_LENGTH);
return ans;
@ -573,8 +573,7 @@ scm_init_readline ()
reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ());
scm_init_opts (scm_readline_options,
scm_readline_opts,
SCM_N_READLINE_OPTIONS);
scm_readline_opts);
init_bouncing_parens();
scm_add_feature ("readline");
#endif /* HAVE_RL_GETC_FUNCTION */

89
ice-9/ChangeLog
View file

@ -1,3 +1,63 @@
2007-02-18 Neil Jerram <neil@ossau.uklinux.net>
* gds-client.scm (connect-to-gds): Break generation of client name
into ...
(client-name): New procedure.
(client-name): Put something from (program-arguments) in the
client name that GDS displays in Emacs.
(connect-to-gds, client-name): Add application-name arg to allow
caller to specify client name.
2007-02-09 Ludovic Courtès <ludovic.courtes@laas.fr>
* Makefile.am (ice9_sources): Added `i18n.scm'.
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* i18n.scm: Use `(ice-9 optargs)'. Don't export `LC_*_MASK'
variables. Added new exports.
(locale-encoding, locale-day-short, locale-day,
locale-month-short, locale-month, locale-am-string,
locale-pm-string, locale-date+time-format, locale-date-format,
locale-time-format, locale-time+am/pm-format, locale-era,
locale-era-year, locale-era-date+time-format,
locale-era-date-format, locale-era-time-format,
locale-currency-symbol, locale-monetary-fractional-digits,
locale-monetary-positive-sign, locale-monetary-negative-sign,
locale-monetary-decimal-point,
locale-monetary-thousands-separator,
locale-monetary-digit-grouping,
locale-currency-symbol-precedes-positive?,
locale-currency-symbol-precedes-negative?,
locale-positive-separated-by-space?,
locale-negative-separated-by-space?,
locale-positive-sign-position, locale-negative-sign-position,
%number-integer-part, add-monetary-sign+currency,
monetary-amount->locale-string, locale-digit-grouping,
locale-decimal-point, locale-thousands-separator,
number->locale-string, locale-yes-regexp, locale-no-regexp): New
procedures.
(define-vector-langinfo-mapping, define-simple-langinfo-mapping,
define-monetary-langinfo-mapping): New macros.
2007-01-04 Kevin Ryde <user42@zip.com.au>
* boot-9.scm (top-repl): Check (defined? 'SIGBUS) before using that
value, there's no such signal on mingw. Reported by Cesar Strauss.
2006-12-13 Kevin Ryde <user42@zip.com.au>
* boot-9.scm (use-srfis, top-repl): Use process-use-modules, to
correctly handle duplicates between the core and other modules, in
particular srfi-17 which should replace `car' etc (but didn't).
2006-12-09 Kevin Ryde <user42@zip.com.au>
* boot-9.scm (top-repl): Remove module-use! of the core `(guile)'
module. It's already in `(guile-user)' and the module-use! elevates
it making core bindings override those from elsewhere, such as `iota'
under a run of "guile --use-srfi=1". Reported by Sven Hartrumpf.
2006-11-13 Neil Jerram <neil@ossau.uklinux.net>
* boot-9.scm (environment-module): Change eval-closure-module call
@ -106,7 +166,7 @@
where `futures' should become `threads' from Marius' change of
2006-01-29.
2006-03-04 Ludovic Courtès <ludovic.courtes@laas.fr>
2006-03-04 Ludovic Courtès <ludovic.courtes@laas.fr>
* ice-9/boot-9.scm (make-autoload-interface): Don't call `set-car!' if
the autoload interface has already been removed from MODULE's uses.
@ -128,7 +188,7 @@
* boot-9.scm (try-module-autoload): Make sure that module code is
loaded with the default reader (current-reader #f). Thanks to
Ludovic Courtès for pointing this problem out.
Ludovic Courtès for pointing this problem out.
* stack-catch.scm (stack-catch): Use catch pre-unwind handler
instead of lazy-catch.
@ -136,7 +196,7 @@
* boot-9.scm (error-catching-loop): Use catch pre-unwind handler
instead of lazy-catch.
2006-02-01 Ludovic Courtès <ludovic.courtes@laas.fr>
2006-02-01 Ludovic Courtès <ludovic.courtes@laas.fr>
* deprecated.scm (make-uniform-array): Fill the returned vector with
PROT, per guile 1.6 behaviour.
@ -152,7 +212,7 @@
2006-01-13 Neil Jerram <neil@ossau.uklinux.net>
* boot-9.scm (repl-reader): Use value of current-reader fluid to
do the read, if set. (Thanks to Ludovic Courtès for the patch.)
do the read, if set. (Thanks to Ludovic Courtès for the patch.)
2005-12-14 Neil Jerram <neil@ossau.uklinux.net>
@ -168,7 +228,7 @@
* boot-9.scm (%cond-expand-features): Add srfi-61.
2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr>
2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr>
* networking.scm (sockaddr:flowinfo, sockaddr:scopeid): New functions.
@ -1197,7 +1257,7 @@
2002-01-12 Marius Vollmer <mvo@zagadka.ping.de>
More options for pretty-print. Thanks to Matthias Köppe!
More options for pretty-print. Thanks to Matthias Köppe!
* pretty-print.scm (generic-write): New per-line-prefix argument.
(pretty-print): Check whether the new keyword argument style is
@ -1274,7 +1334,7 @@
* session.scm (arity): Use new `arglist' procedure property to
present a more detailed argument list.
Thanks to Matthias Köppe!
Thanks to Matthias Köppe!
2001-09-07 Thien-Thi Nguyen <ttn@revel.glug.org>
@ -1493,12 +1553,12 @@
* optargs.scm (lambda*): Make sure that BODY is always put into a
real body context so that it can contain internal definitions.
Thanks to Matthias Köppe!
Thanks to Matthias Köppe!
* format.scm: Use (ice-9 and-let-star).
(format:out): Initialize format:output-col with current column of
`port', if it has one. Else leave it alone. Thanks to Matthias
Köppe!
Köppe!
2001-06-05 Marius Vollmer <mvo@zagadka.ping.de>
@ -1603,7 +1663,7 @@
* boot-9.scm (define-module): Return the new module.
(process-define-module): Use `spec' instead of `module-name' when
getting the syntax transformer. Thanks to Matthias Köppe!
getting the syntax transformer. Thanks to Matthias Köppe!
2001-05-21 Marius Vollmer <mvo@zagadka.ping.de>
@ -1713,7 +1773,7 @@
* boot-9.scm (error-catching-repl): Call the E
("eval'er") procedure via call-with-values and call the P
("printer") for each produced value. Thanks to Matthias Köppe!
("printer") for each produced value. Thanks to Matthias Köppe!
2001-05-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
@ -2234,7 +2294,7 @@
2000-08-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* format.scm (format:obj->str): Made tail-recursive. (Thanks to
Matthias Köppe.)
Matthias Köppe.)
2000-08-13 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
@ -2333,7 +2393,7 @@
2000-06-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* session.scm (make-fold-modules): Detect circular references in
module graph. (Thanks to Matthias Köppe.)
module graph. (Thanks to Matthias Köppe.)
2000-06-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
@ -4795,3 +4855,6 @@ Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive>
* The more things change...
;; Local Variables:
;; coding: utf-8
;; End:

25
ice-9/Makefile.am
View file

@ -24,18 +24,19 @@ AUTOMAKE_OPTIONS = gnu
SUBDIRS = debugger debugging
# These should be installed and distributed.
ice9_sources = \
and-let-star.scm boot-9.scm calling.scm common-list.scm \
debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \
match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \
posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \
rdelim.scm receive.scm regex.scm runq.scm rw.scm \
safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \
streams.scm string-fun.scm syncase.scm threads.scm \
buffered-input.scm time.scm history.scm channel.scm \
pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \
weak-vector.scm deprecated.scm list.scm serialize.scm \
ice9_sources = \
and-let-star.scm boot-9.scm calling.scm common-list.scm \
debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
format.scm getopt-long.scm hcons.scm i18n.scm \
lineio.scm ls.scm mapping.scm \
match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \
posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \
rdelim.scm receive.scm regex.scm runq.scm rw.scm \
safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \
streams.scm string-fun.scm syncase.scm threads.scm \
buffered-input.scm time.scm history.scm channel.scm \
pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \
weak-vector.scm deprecated.scm list.scm serialize.scm \
gds-client.scm gds-server.scm
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9

44
ice-9/boot-9.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file
;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006
;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -3313,13 +3313,11 @@
;; numbers, which are the numbers of the SRFIs to be loaded on startup.
;;
(define (use-srfis srfis)
(let lp ((s srfis))
(if (pair? s)
(let* ((srfi (string->symbol
(string-append "srfi-" (number->string (car s)))))
(mod-i (resolve-interface (list 'srfi srfi))))
(module-use! (current-module) mod-i)
(lp (cdr s))))))
(process-use-modules
(map (lambda (num)
(list (list 'srfi (string->symbol
(string-append "srfi-" (number->string num))))))
srfis)))
@ -3387,30 +3385,38 @@
;; Use some convenient modules (in reverse order)
(if (provided? 'regex)
(module-use! guile-user-module (resolve-interface '(ice-9 regex))))
(if (provided? 'threads)
(module-use! guile-user-module (resolve-interface '(ice-9 threads))))
(set-current-module guile-user-module)
(process-use-modules
(append
'(((ice-9 r5rs))
((ice-9 session))
((ice-9 debug)))
(if (provided? 'regex)
'(((ice-9 regex)))
'())
(if (provided? 'threads)
'(((ice-9 threads)))
'())))
;; load debugger on demand
(module-use! guile-user-module
(make-autoload-interface guile-user-module
'(ice-9 debugger) '(debug)))
(module-use! guile-user-module (resolve-interface '(ice-9 session)))
(module-use! guile-user-module (resolve-interface '(ice-9 debug)))
;; so that builtin bindings will be checked first
(module-use! guile-user-module (resolve-interface '(ice-9 r5rs)))
(module-use! guile-user-module (resolve-interface '(guile)))
(set-current-module guile-user-module)
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
;; no effect.
(let ((old-handlers #f)
(signals (if (provided? 'posix)
`((,SIGINT . "User interrupt")
(,SIGFPE . "Arithmetic error")
(,SIGBUS . "Bad memory access (bus error)")
(,SIGSEGV
. "Bad memory access (Segmentation violation)"))
'())))
;; no SIGBUS on mingw
(if (defined? 'SIGBUS)
(set! signals (acons SIGBUS "Bad memory access (bus error)"
signals)))
(dynamic-wind

16
ice-9/gds-client.scm
View file

@ -170,7 +170,7 @@
(safely-handle-nondebug-protocol protocol)
(loop (gds-debug-read))))))))
(define (connect-to-gds)
(define (connect-to-gds . application-name)
(or gds-port
(begin
(set! gds-port
@ -190,7 +190,19 @@
s)
(lambda _ #f)))
(error "Couldn't connect to GDS by TCP or Unix domain socket")))
(write-form (list 'name (getpid) (format #f "PID ~A" (getpid)))))))
(write-form (list 'name (getpid) (apply client-name application-name))))))
(define (client-name . application-name)
(let loop ((args (append application-name (program-arguments))))
(if (null? args)
(format #f "PID ~A" (getpid))
(let ((arg (car args)))
(cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
(loop (cdr args)))
((string-match "^-" arg)
(loop (cdr args)))
(else
(format #f "~A (PID ~A)" arg (getpid))))))))
(if (not (defined? 'make-mutex))
(begin

378
ice-9/i18n.scm
View file

@ -1,6 +1,6 @@
;;;; i18n.scm --- internationalization support
;;;; Copyright (C) 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 2006, 2007 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
@ -29,18 +29,10 @@
;;; Code:
(define-module (ice-9 i18n)
:use-module (ice-9 optargs)
:export (;; `locale' type
make-locale locale?
;; locale category masks (standard)
LC_ALL_MASK
LC_COLLATE_MASK LC_CTYPE_MASK LC_MESSAGES_MASK
LC_MONETARY_MASK LC_NUMERIC_MASK LC_TIME_MASK
;; locale category masks (non-standard)
LC_PAPER_MASK LC_NAME_MASK LC_ADDRESS_MASK
LC_TELEPHONE_MASK LC_MEASUREMENT_MASK
LC_IDENTIFICATION_MASK
%global-locale
;; text collation
string-locale<? string-locale>?
@ -54,11 +46,373 @@
string-locale-downcase string-locale-upcase
;; reading numbers
locale-string->integer locale-string->inexact))
locale-string->integer locale-string->inexact
;; charset/encoding
locale-encoding
;; days and months
locale-day-short locale-day locale-month-short locale-month
;; date and time
locale-am-string locale-pm-string
locale-date+time-format locale-date-format locale-time-format
locale-time+am/pm-format
locale-era locale-era-year
locale-era-date-format locale-era-date+time-format
locale-era-time-format
;; monetary
locale-currency-symbol
locale-monetary-decimal-point locale-monetary-thousands-separator
locale-monetary-grouping locale-monetary-fractional-digits
locale-currency-symbol-precedes-positive?
locale-currency-symbol-precedes-negative?
locale-positive-separated-by-space?
locale-negative-separated-by-space?
locale-monetary-positive-sign locale-monetary-negative-sign
locale-positive-sign-position locale-negative-sign-position
monetary-amount->locale-string
;; number formatting
locale-digit-grouping locale-decimal-point
locale-thousands-separator
number->locale-string
;; miscellaneous
locale-yes-regexp locale-no-regexp))
(load-extension "libguile-i18n-v-0" "scm_init_i18n")
;;;
;;; Charset/encoding.
;;;
(define (locale-encoding . locale)
(apply nl-langinfo CODESET locale))
;;;
;;; Months and days.
;;;
;; Helper macro: Define a procedure named NAME that maps its argument to
;; NL-ITEMS (when `nl-langinfo' is provided) or DEFAULTS (when `nl-langinfo'
;; is not provided).
(define-macro (define-vector-langinfo-mapping name nl-items defaults)
(let* ((item-count (length nl-items))
(defines (if (provided? 'nl-langinfo)
`(define %nl-items (vector #f ,@nl-items))
`(define %defaults (vector #f ,@defaults))))
(make-body (lambda (result)
`(if (and (integer? item) (exact? item))
(if (and (>= item 1) (<= item ,item-count))
,result
(throw 'out-of-range "out of range" item))
(throw 'wrong-type-arg "wrong argument type" item)))))
`(define (,name item . locale)
,defines
,(make-body (if (provided? 'nl-langinfo)
'(apply nl-langinfo (vector-ref %nl-items item) locale)
'(vector-ref %defaults item))))))
(define-vector-langinfo-mapping locale-day-short
(ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7)
("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
(define-vector-langinfo-mapping locale-day
(DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7)
("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
(define-vector-langinfo-mapping locale-month-short
(ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12)
("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
(define-vector-langinfo-mapping locale-month
(MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12)
("January" "February" "March" "April" "May" "June" "July" "August"
"September" "October" "November" "December"))
;;;
;;; Date and time.
;;;
;; Helper macro: Define a procedure NAME that gets langinfo item ITEM.
(define-macro (define-simple-langinfo-mapping name item default)
(let ((body (if (and (provided? 'nl-langinfo) (defined? item))
`(apply nl-langinfo ,item locale)
default)))
`(define (,name . locale)
,body)))
(define-simple-langinfo-mapping locale-am-string
AM_STR "AM")
(define-simple-langinfo-mapping locale-pm-string
PM_STR "PM")
(define-simple-langinfo-mapping locale-date+time-format
D_T_FMT "%a %b %e %H:%M:%S %Y")
(define-simple-langinfo-mapping locale-date-format
D_FMT "%m/%d/%y")
(define-simple-langinfo-mapping locale-time-format
T_FMT "%H:%M:%S")
(define-simple-langinfo-mapping locale-time+am/pm-format
T_FMT_AMPM "%I:%M:%S %p")
(define-simple-langinfo-mapping locale-era
ERA "")
(define-simple-langinfo-mapping locale-era-year
ERA_YEAR "")
(define-simple-langinfo-mapping locale-era-date+time-format
ERA_D_T_FMT "")
(define-simple-langinfo-mapping locale-era-date-format
ERA_D_FMT "")
(define-simple-langinfo-mapping locale-era-time-format
ERA_T_FMT "")
;;;
;;; Monetary information.
;;;
(define-macro (define-monetary-langinfo-mapping name local-item intl-item
default/local default/intl)
(let ((body
(let ((intl (if (and (provided? 'nl-langinfo) (defined? intl-item))
`(apply nl-langinfo ,intl-item locale)
default/intl))
(local (if (and (provided? 'nl-langinfo) (defined? local-item))
`(apply nl-langinfo ,local-item locale)
default/local)))
`(if intl? ,intl ,local))))
`(define (,name intl? . locale)
,body)))
;; FIXME: How can we use ALT_DIGITS?
(define-monetary-langinfo-mapping locale-currency-symbol
CRNCYSTR INT_CURR_SYMBOL
"-" "")
(define-monetary-langinfo-mapping locale-monetary-fractional-digits
FRAC_DIGITS INT_FRAC_DIGITS
2 2)
(define-simple-langinfo-mapping locale-monetary-positive-sign
POSITIVE_SIGN "+")
(define-simple-langinfo-mapping locale-monetary-negative-sign
NEGATIVE_SIGN "-")
(define-simple-langinfo-mapping locale-monetary-decimal-point
MON_DECIMAL_POINT "")
(define-simple-langinfo-mapping locale-monetary-thousands-separator
MON_THOUSANDS_SEP "")
(define-simple-langinfo-mapping locale-monetary-digit-grouping
MON_GROUPING '())
(define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive?
P_CS_PRECEDES INT_P_CS_PRECEDES
#t #t)
(define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative?
N_CS_PRECEDES INT_N_CS_PRECEDES
#t #t)
(define-monetary-langinfo-mapping locale-positive-separated-by-space?
;; Whether a space should be inserted between a positive amount and the
;; currency symbol.
P_SEP_BY_SPACE INT_P_SEP_BY_SPACE
#t #t)
(define-monetary-langinfo-mapping locale-negative-separated-by-space?
;; Whether a space should be inserted between a negative amount and the
;; currency symbol.
N_SEP_BY_SPACE INT_N_SEP_BY_SPACE
#t #t)
(define-monetary-langinfo-mapping locale-positive-sign-position
;; Position of the positive sign wrt. currency symbol and quantity in a
;; monetary amount.
P_SIGN_POSN INT_P_SIGN_POSN
'unspecified 'unspecified)
(define-monetary-langinfo-mapping locale-negative-sign-position
;; Position of the negative sign wrt. currency symbol and quantity in a
;; monetary amount.
N_SIGN_POSN INT_N_SIGN_POSN
'unspecified 'unspecified)
(define (%number-integer-part int grouping separator)
;; Process INT (a string denoting a number's integer part) and return a new
;; string with digit grouping and separators according to GROUPING (a list,
;; potentially circular) and SEPARATOR (a string).
;; Process INT from right to left.
(let loop ((int int)
(grouping grouping)
(result '()))
(cond ((string=? int "") (apply string-append result))
((null? grouping) (apply string-append int result))
(else
(let* ((len (string-length int))
(cut (min (car grouping) len)))
(loop (substring int 0 (- len cut))
(cdr grouping)
(let ((sub (substring int (- len cut) len)))
(if (> len cut)
(cons* separator sub result)
(cons sub result)))))))))
(define (add-monetary-sign+currency amount figure intl? locale)
;; Add a sign and currency symbol around FIGURE. FIGURE should be a
;; formatted unsigned amount (a string) representing AMOUNT.
(let* ((positive? (> amount 0))
(sign
(cond ((> amount 0) (locale-monetary-positive-sign locale))
((< amount 0) (locale-monetary-negative-sign locale))
(else "")))
(currency (locale-currency-symbol intl? locale))
(currency-precedes?
(if positive?
locale-currency-symbol-precedes-positive?
locale-currency-symbol-precedes-negative?))
(separated?
(if positive?
locale-positive-separated-by-space?
locale-negative-separated-by-space?))
(sign-position
(if positive?
locale-positive-sign-position
locale-negative-sign-position))
(currency-space
(if (separated? intl? locale) " " ""))
(append-currency
(lambda (amt)
(if (currency-precedes? intl? locale)
(string-append currency currency-space amt)
(string-append amt currency-space currency)))))
(case (sign-position intl? locale)
((parenthesize)
(string-append "(" (append-currency figure) ")"))
((sign-before)
(string-append sign (append-currency figure)))
((sign-after unspecified)
;; following glibc's recommendation for `unspecified'.
(if (currency-precedes? intl? locale)
(string-append currency currency-space sign figure)
(string-append figure currency-space currency sign)))
((sign-before-currency-symbol)
(if (currency-precedes? intl? locale)
(string-append sign currency currency-space figure)
(string-append figure currency-space sign currency))) ;; unlikely
((sign-after-currency-symbol)
(if (currency-precedes? intl? locale)
(string-append currency sign currency-space figure)
(string-append figure currency-space currency sign)))
(else
(error "unsupported sign position" (sign-position intl? locale))))))
(define* (monetary-amount->locale-string amount intl?
#:optional (locale %global-locale))
"Convert @var{amount} (an inexact) into a string according to the cultural
conventions of either @var{locale} (a locale object) or the current locale.
If @var{intl?} is true, then the international monetary format for the given
locale is used."
(let* ((fraction-digits
(or (locale-monetary-fractional-digits intl? locale) 2))
(decimal-part
(lambda (dec)
(if (or (string=? dec "") (eq? 0 fraction-digits))
""
(string-append (locale-monetary-decimal-point locale)
(if (< fraction-digits (string-length dec))
(substring dec 0 fraction-digits)
dec)))))
(external-repr (number->string (if (> amount 0) amount (- amount))))
(int+dec (string-split external-repr #\.))
(int (car int+dec))
(dec (decimal-part (if (null? (cdr int+dec))
""
(cadr int+dec))))
(grouping (locale-monetary-digit-grouping locale))
(separator (locale-monetary-thousands-separator locale)))
(add-monetary-sign+currency amount
(string-append
(%number-integer-part int grouping
separator)
dec)
intl? locale)))
;;;
;;; Number formatting.
;;;
(define-simple-langinfo-mapping locale-digit-grouping
GROUPING '())
(define-simple-langinfo-mapping locale-decimal-point
RADIXCHAR ".")
(define-simple-langinfo-mapping locale-thousands-separator
THOUSEP "")
(define* (number->locale-string number
#:optional (fraction-digits #t)
(locale %global-locale))
"Convert @var{number} (an inexact) into a string according to the cultural
conventions of either @var{locale} (a locale object) or the current locale.
Optionally, @var{fraction-digits} may be bound to an integer specifying the
number of fractional digits to be displayed."
(let* ((sign
(cond ((> number 0) "")
((< number 0) "-")
(else "")))
(decimal-part
(lambda (dec)
(if (or (string=? dec "") (eq? 0 fraction-digits))
""
(string-append (locale-decimal-point locale)
(if (and (integer? fraction-digits)
(< fraction-digits
(string-length dec)))
(substring dec 0 fraction-digits)
dec))))))
(let* ((external-repr (number->string (if (> number 0)
number
(- number))))
(int+dec (string-split external-repr #\.))
(int (car int+dec))
(dec (decimal-part (if (null? (cdr int+dec))
""
(cadr int+dec))))
(grouping (locale-digit-grouping locale))
(separator (locale-thousands-separator locale)))
(string-append sign
(%number-integer-part int grouping separator)
dec))))
;;;
;;; Miscellaneous.
;;;
(define-simple-langinfo-mapping locale-yes-regexp
YESEXPR "^[yY]")
(define-simple-langinfo-mapping locale-no-regexp
NOEXPR "^[nN]")
;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.
;;; Local Variables:
;;; coding: latin-1

250
libguile/ChangeLog
View file

@ -1,16 +1,262 @@
2007-02-19 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am (noinst_HEADERS): Add private-options.h, so that it
is included in the distribution.
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* i18n.c: Include "libguile/threads.h" and "libguile/posix.h"
unconditionally. Include <langinfo.h> and <nl_types.h> when
available.
(SCM_I18N_STRINGIFY, SCM_LOCALE_CATEGORY_MASK,
SCM_LIST_OR_INTEGER_P): New macros.
(LC_*_MASK): When `USE_GNU_LOCALE_API' is undefined, define them
as powers of two instead of `(1 << LC_*)'.
(scm_i_locale_free): New function/macro.
(scm_global_locale): New global variable.
(smob_locale_free): Use `scm_i_locale_free ()'.
(smob_locale_mark): Check whether the SMOB is `%global-locale'.
(get_current_locale_settings): Return `EINVAL' instead of `errno'
when `setlocale' fails.
(restore_locale_settings): Likewise.
(install_locale_categories): Likewise.
(install_locale): Likewise. Stop the locale stack traversal when
all categories have been handled.
(get_current_locale, category_to_category_mask,
category_list_to_category_mask): New function.
(scm_make_locale): Use them. Accept both lists of `LC_*' values
and single `LC_*' values as the first argument. Handle the case
where BASE_LOCALE is `%global-locale'. When `USE_GNU_LOCALE_API',
duplicate C_BASE_LOCALE before using it.
(scm_nl_langinfo, define_langinfo_items): New functions.
(scm_init_i18n): When `HAVE_NL_LANGINFO', add feature
`nl-langinfo' and invoke `define_langinfo_items ()'.
* i18n.h (scm_global_locale, scm_nl_langinfo): New declarations.
* posix.c: Include <xlocale.h> when available.
(scm_i_locale_mutex): Always define it. Statically initialized.
(scm_set_locale): Invoke `scm_i_to_lc_category ()' before
acquiring the locale mutex.
(scm_init_posix): No longer initialize SCM_I_LOCALE_MUTEX here.
2007-01-25 Han-Wen Nienhuys <hanwen@lilypond.org>
* vector.c: remove comment as per kryde's request.
2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org>
* vectors.c (s_scm_vector_move_right_x): complain about naming.
* srcprop.c: regularize comments.
* eval.c: remove superfluous ifndef DEVAL.
* private-options.h: idem.
* eval.i.c: copyright nitpicking.
* eval.c: distangle. move duplicate code to eval.i.c and include
twice.
* eval.i.c: new file.
* backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c
eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c,
read.h, stacks.c, symbols.c, throw.c: use private-options.h
* private-options.h: new file: contain hardcoded option
definitions.
* private-gc.h: add FSF header.
2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org>
* debug.h (SCM_RESET_DEBUG_MODE): switch to debugging if
memoize-symbol is set.
* eval.h (SCM_MEMOIZE_HDLR): add macros for memoize symbol trap.
* eval.c (CEVAL): add memoize_symbol trap.
* options.c (scm_options_try): new function. This allows error
reporting before changing options in a critical section.
* srcprop.c: use double cell for storing source-properties. Put
filename in the plist, and share between srcprops if possible.
Remove specialized storage.
* srcprop.h: remove macros without SCM_ prefix from
interface. Remove specialized storage/type definitions.
* read.c: idem.
* print.c: idem.
* eval.c: terminate option lists with 0.
* options.c: remove n (for length) from scm_option_X
functions. Detect option list length by looking for NULL name.
2007-01-19 Ludovic Courtès <ludovic.courtes@laas.fr>
* struct.c (scm_i_struct_equalp): Skip comparison if both FIELD1
is equal to S1 and FIELD2 is equal to S2. This avoids infinite
recursion when comparing `s' fields, as the REQUIRED_VTABLE_FIELDS
added by `make-vtable-vtable'. Reported by Marco Maggi.
2007-01-18 Han-Wen Nienhuys <hanwen@lilypond.org>
* throw.c (scm_ithrow): more refined error message: print symbols
too.
2007-01-16 Kevin Ryde <user42@zip.com.au>
* feature.c, feature.h (scm_set_program_arguments_scm): New function,
implementing `set-program-arguments'.
* filesys.c (scm_init_filesys): Use scm_from_int rather than
scm_from_long for O_RDONLY, O_WRONLY, O_RDWR, O_CREAT, O_EXCL,
O_NOCTTY, O_TRUNC, O_APPEND, O_NONBLOCK, O_NDELAY, O_SYNC and
O_LARGEFILE. These are all int not long, per arg to open().
(scm_init_filesys): Use scm_from_int rather than scm_from_long for
F_DUPFD, F_GETFD, F_SETFD, F_GETFL, F_SETFL, F_GETOWN, F_SETOWN, these
are all ints (per command arg to fcntl). Likewise FD_CLOEXEC which is
an int arg to fcntl.
* posix.c (scm_putenv): Correction to "len" variable, was defined only
for __MINGW32__ but used under any !HAVE_UNSETENV (such as solaris).
Move it to where it's used. Reported by Hugh Sasse.
* regex-posix.c (scm_regexp_exec): Remove SCM_CRITICAL_SECTION_START
and SCM_CRITICAL_SECTION_END, believe not needed. Their placement
meant #\nul in the input (detected by scm_to_locale_string) and a bad
flags arg (detected by scm_to_int) would throw from a critical
section, causing an abort().
* regex-posix.c (scm_init_regex_posix): Use scm_from_int for
REG_BASIC, REG_EXTENDED, REG_ICASE, REG_NEWLINE, REG_NOTBOL,
REG_NOTEOL; they're all ints not longs (per args to regcomp and
regexec).
2007-01-10 Han-Wen Nienhuys <hanwen@lilypond.org>
* throw.c (scm_ithrow): print out key symbol and string arguments
when error happens inside a critical section, and document why.
2007-01-06 Han-Wen Nienhuys <hanwen@lilypond.org>
* read.c (s_scm_read_hash_extend): document #f argument to
read-hash-extend.
2007-01-04 Kevin Ryde <user42@zip.com.au>
* deprecated.h (scm_create_hook), version.h.in (scm_major_version,
scm_minor_version, scm_micro_version, scm_effective_version,
scm_version, scm_init_version): Use SCM_API instead of just extern,
for the benefit of mingw. Reported by Cesar Strauss.
2007-01-03 Han-Wen Nienhuys <hanwen@lilypond.org>
* gc.c (s_scm_gc_stats): return an entry for total-cells-allocated
too.
(gc_update_stats): update scm_gc_cells_allocated_acc too.
2006-12-27 Kevin Ryde <user42@zip.com.au>
* threads.c (get_thread_stack_base): In mingw with pthreads we can use
the basic scm_get_stack_base. As advised by Nils Durner.
* threads.c (get_thread_stack_base): Add a version using
pthread_get_stackaddr_np (when available), for the benefit of MacOS.
As advised by Heikki Lindholm.
* scmsigs.c (signal_delivery_thread): Restrict scm_i_pthread_sigmask
to HAVE_PTHREAD_SIGMASK, it doesn't exist on mingw. Reported by Nils
Durner.
2006-12-24 Kevin Ryde <user42@zip.com.au>
* posix.c (scm_kill): When only raise() is available, throw an ENOSYS
error if pid is not our own process, instead of silently doing nothing.
* print.c (scm_write, scm_display, scm_write_char): Disable port close
on EPIPE. This was previously disabled but introduction of HAVE_PIPE
check in configure.in unintentionally enabled it. Believe that
testing errno after scm_prin1 or scm_putc is bogus, a long ago error
can leave errno in that state. popen.test "no duplicates" output test
provoked that.
2006-12-23 Han-Wen Nienhuys <hanwen@lilypond.org>
* numbers.c (scm_i_fraction_reduce): move logic into
scm_i_make_ratio(), so fractions are only read.
scm_i_fraction_reduce() modifies a fraction when reading it. A
race condition might lead to fractions being corrupted by reading
them concurrently.
Also, the REDUCED bit alters the SCM_CELL_TYPE(), making
comparisons between reduced and unreduced fractions go wrong.
* numbers.h: remove SCM_FRACTION_SET_NUMERATOR,
SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT,
SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR,
SCM_FRACTION_REDUCED.
2006-12-16 Kevin Ryde <user42@zip.com.au>
* scmsigs.c (scm_raise): Use raise() rather than kill(), as this is
more direct for a procedure called raise.
(kill): Remove mingw fake fallback.
2006-12-15 Kevin Ryde <user42@zip.com.au>
* scmsigs.c: Conditionalize process.h, add io.h believe needed for
_pipe on mingw.
2006-12-14 Kevin Ryde <user42@zip.com.au>
* threads.c (thread_print): Cope with the case where pthread_t is a
struct, as found on mingw. Can't just cast to size_t for printing.
Reported by Nils Durner.
* scmsigs.c: Add <fcntl.h> and <process.h> needed by mingw. Copy the
fallback pipe() using _pipe() from posix.c. Reported by Nils Durner.
2006-12-13 Kevin Ryde <user42@zip.com.au>
* eval.c (scm_m_define): Set 'name procedure property on any
scm_procedure_p, not just SCM_CLOSUREP. In particular this picks up
procedures with setters as used in srfi-17.
* posix.c (scm_crypt): Check for NULL return from crypt(), which the
linux man page says is a possibility.
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
instead of RES (reported by Szavai Gyula). This allows the use of
negative lower bounds.
(scm_i_read_array): Make sure LEN is non-negative (reported by
Gyula Szavai).
Szavai Gyula).
(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-12-05 Kevin Ryde <user42@zip.com.au>
* numbers.c (scm_product): For flonum*inum and complex*inum, return
exact 0 if inum==0. Already done for inum*flonum and inum*complex,
and as per R5RS section "Exactness".
2006-12-03 Kevin Ryde <user42@zip.com.au>
* Makefile.am (.c.doc): Remove the "test -n" apparently attempting to
allow $AWK from the environment to override. It had syntax gremlins,
and the presence of a $(AWK) variable set by AC_PROG_AWK in the
Makefile stopped it having any effect. Use just $(AWK), which can be
overridden with "make AWK=xxx" in the usual way if desired.
2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
* libguile/vectors.c (scm_vector_to_list): Fixed list

4
libguile/Makefile.am
View file

@ -182,7 +182,7 @@ noinst_HEADERS = convert.i.c \
srfi-4.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
private-gc.h
private-gc.h private-options.h
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@
@ -283,7 +283,7 @@ SUFFIXES = .x .doc
.c.x:
./guile-snarf -o $@ $< $(snarfcppopts)
.c.doc:
-(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<)
-$(AWK) -f ./guile-func-name-check $<
(./guile-snarf-docs $(snarfcppopts) $< | \
./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; }

1
libguile/backtrace.c
View file

@ -47,6 +47,7 @@
#include "libguile/lang.h"
#include "libguile/backtrace.h"
#include "libguile/filesys.h"
#include "libguile/private-options.h"
/* {Error reporting and backtraces}
*

11
libguile/debug.c
View file

@ -42,8 +42,11 @@
#include "libguile/validate.h"
#include "libguile/debug.h"
#include "libguile/private-options.h"
/* {Run time control of the debugging evaluator}
*/
@ -59,10 +62,10 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
scm_dynwind_begin (0);
scm_dynwind_critical_section (SCM_BOOL_F);
ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
{
scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
scm_options (ans, scm_debug_opts, FUNC_NAME);
SCM_OUT_OF_RANGE (1, setting);
}
SCM_RESET_DEBUG_MODE;
@ -74,6 +77,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
}
#undef FUNC_NAME
static void
with_traps_before (void *data)
{
@ -112,7 +116,6 @@ SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
#undef FUNC_NAME
SCM_SYMBOL (scm_sym_procname, "procname");
SCM_SYMBOL (scm_sym_dots, "...");
SCM_SYMBOL (scm_sym_source, "source");
@ -526,7 +529,7 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
void
scm_init_debug ()
{
scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
scm_init_opts (scm_debug_options, scm_debug_opts);
scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
scm_set_smob_print (scm_tc16_memoized, memoized_print);

21
libguile/debug.h
View file

@ -42,28 +42,13 @@
/* scm_debug_opts is defined in eval.c.
*/
SCM_API scm_t_option scm_debug_opts[];
#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
#define SCM_TRACE_P scm_debug_opts[2].val
#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
#define SCM_BACKWARDS_P scm_debug_opts[4].val
#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val
#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val
#define SCM_N_FRAMES scm_debug_opts[7].val
#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val
#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val
#define SCM_BACKTRACE_P scm_debug_opts[10].val
#define SCM_DEVAL_P scm_debug_opts[11].val
#define SCM_STACK_LIMIT scm_debug_opts[12].val
#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val
#define SCM_WARN_DEPRECATED scm_debug_opts[14].val
#define SCM_N_DEBUG_OPTIONS 15
SCM_API int scm_debug_mode_p;
SCM_API int scm_check_entry_p;
SCM_API int scm_check_apply_p;
SCM_API int scm_check_exit_p;
SCM_API int scm_check_memoize_p;
#define SCM_RESET_DEBUG_MODE \
do {\
@ -73,8 +58,10 @@ do {\
&& scm_is_true (SCM_APPLY_FRAME_HDLR);\
scm_check_exit_p = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\
&& scm_is_true (SCM_EXIT_FRAME_HDLR);\
scm_check_memoize_p = (SCM_MEMOIZE_P)\
&& scm_is_true (SCM_MEMOIZE_HDLR);\
scm_debug_mode_p = SCM_DEVAL_P\
|| scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
|| scm_check_memoize_p || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
} while (0)
/* {Evaluator}

4
libguile/deprecated.h
View file

@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
/* Copyright (C) 2003,2004, 2005, 2006 Free Software Foundation, Inc.
/* Copyright (C) 2003,2004, 2005, 2006, 2007 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
@ -164,7 +164,7 @@ SCM_API SCM scm_make_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf);
extern SCM scm_create_hook (const char* name, int n_args);
SCM_API SCM scm_create_hook (const char* name, int n_args);
#define SCM_LIST0 SCM_EOL
#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)

3
libguile/deprecation.c
View file

@ -31,6 +31,9 @@
#include "libguile/strings.h"
#include "libguile/ports.h"
#include "libguile/private-options.h"
/* Windows defines. */
#ifdef __MINGW32__
#define vsnprintf _vsnprintf

3
libguile/eq.c
View file

@ -36,6 +36,9 @@
#include "libguile/validate.h"
#include "libguile/eq.h"
#include "libguile/private-options.h"
#ifdef HAVE_STRING_H

2082
libguile/eval.c
View file

File diff suppressed because it is too large Load diff

19
libguile/eval.h
View file

@ -32,25 +32,6 @@
/* {Options}
*/
SCM_API scm_t_option scm_eval_opts[];
#define SCM_EVAL_STACK scm_eval_opts[0].val
#define SCM_N_EVAL_OPTIONS 1
SCM_API long scm_eval_stack;
SCM_API scm_t_option scm_evaluator_trap_table[];
SCM_API SCM scm_eval_options_interface (SCM setting);
#define SCM_TRAPS_P scm_evaluator_trap_table[0].val
#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val
#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val
#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val
#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val))
#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val))
#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val))
#define SCM_N_EVALUATOR_TRAPS 7

1942
libguile/eval.i.c Normal file
View file

File diff suppressed because it is too large Load diff

18
libguile/feature.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 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
@ -76,6 +76,22 @@ scm_set_program_arguments (int argc, char **argv, char *first)
scm_fluid_set_x (progargs_fluid, args);
}
SCM_DEFINE (scm_set_program_arguments_scm, "set-program-arguments", 1, 0, 0,
(SCM lst),
"Set the command line arguments to be returned by\n"
"@code{program-arguments} (and @code{command-line}). @var{lst}\n"
"should be a list of strings, the first of which is the program\n"
"name (either a script name, or just @code{\"guile\"}).\n"
"\n"
"Program arguments are held in a fluid and therefore have a\n"
"separate value in each Guile thread. Neither the list nor the\n"
"strings within it are copied, so should not be modified later.")
#define FUNC_NAME s_scm_set_program_arguments_scm
{
return scm_fluid_set_x (progargs_fluid, lst);
}
#undef FUNC_NAME

3
libguile/feature.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_FEATURE_H
#define SCM_FEATURE_H
/* Copyright (C) 1995,1996,1999,2000,2001, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2007 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
@ -27,6 +27,7 @@
SCM_API void scm_add_feature (const char* str);
SCM_API SCM scm_program_arguments (void);
SCM_API void scm_set_program_arguments (int argc, char **argv, char *first);
SCM_API SCM scm_set_program_arguments_scm (SCM lst);
SCM_API void scm_init_feature (void);
#endif /* SCM_FEATURE_H */

40
libguile/filesys.c
View file

@ -1681,65 +1681,65 @@ scm_init_filesys ()
scm_dot_string = scm_permanent_object (scm_from_locale_string ("."));
#ifdef O_RDONLY
scm_c_define ("O_RDONLY", scm_from_long (O_RDONLY));
scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
#endif
#ifdef O_WRONLY
scm_c_define ("O_WRONLY", scm_from_long (O_WRONLY));
scm_c_define ("O_WRONLY", scm_from_int (O_WRONLY));
#endif
#ifdef O_RDWR
scm_c_define ("O_RDWR", scm_from_long (O_RDWR));
scm_c_define ("O_RDWR", scm_from_int (O_RDWR));
#endif
#ifdef O_CREAT
scm_c_define ("O_CREAT", scm_from_long (O_CREAT));
scm_c_define ("O_CREAT", scm_from_int (O_CREAT));
#endif
#ifdef O_EXCL
scm_c_define ("O_EXCL", scm_from_long (O_EXCL));
scm_c_define ("O_EXCL", scm_from_int (O_EXCL));
#endif
#ifdef O_NOCTTY
scm_c_define ("O_NOCTTY", scm_from_long (O_NOCTTY));
scm_c_define ("O_NOCTTY", scm_from_int (O_NOCTTY));
#endif
#ifdef O_TRUNC
scm_c_define ("O_TRUNC", scm_from_long (O_TRUNC));
scm_c_define ("O_TRUNC", scm_from_int (O_TRUNC));
#endif
#ifdef O_APPEND
scm_c_define ("O_APPEND", scm_from_long (O_APPEND));
scm_c_define ("O_APPEND", scm_from_int (O_APPEND));
#endif
#ifdef O_NONBLOCK
scm_c_define ("O_NONBLOCK", scm_from_long (O_NONBLOCK));
scm_c_define ("O_NONBLOCK", scm_from_int (O_NONBLOCK));
#endif
#ifdef O_NDELAY
scm_c_define ("O_NDELAY", scm_from_long (O_NDELAY));
scm_c_define ("O_NDELAY", scm_from_int (O_NDELAY));
#endif
#ifdef O_SYNC
scm_c_define ("O_SYNC", scm_from_long (O_SYNC));
scm_c_define ("O_SYNC", scm_from_int (O_SYNC));
#endif
#ifdef O_LARGEFILE
scm_c_define ("O_LARGEFILE", scm_from_long (O_LARGEFILE));
scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
#endif
#ifdef F_DUPFD
scm_c_define ("F_DUPFD", scm_from_long (F_DUPFD));
scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));
#endif
#ifdef F_GETFD
scm_c_define ("F_GETFD", scm_from_long (F_GETFD));
scm_c_define ("F_GETFD", scm_from_int (F_GETFD));
#endif
#ifdef F_SETFD
scm_c_define ("F_SETFD", scm_from_long (F_SETFD));
scm_c_define ("F_SETFD", scm_from_int (F_SETFD));
#endif
#ifdef F_GETFL
scm_c_define ("F_GETFL", scm_from_long (F_GETFL));
scm_c_define ("F_GETFL", scm_from_int (F_GETFL));
#endif
#ifdef F_SETFL
scm_c_define ("F_SETFL", scm_from_long (F_SETFL));
scm_c_define ("F_SETFL", scm_from_int (F_SETFL));
#endif
#ifdef F_GETOWN
scm_c_define ("F_GETOWN", scm_from_long (F_GETOWN));
scm_c_define ("F_GETOWN", scm_from_int (F_GETOWN));
#endif
#ifdef F_SETOWN
scm_c_define ("F_SETOWN", scm_from_long (F_SETOWN));
scm_c_define ("F_SETOWN", scm_from_int (F_SETOWN));
#endif
#ifdef FD_CLOEXEC
scm_c_define ("FD_CLOEXEC", scm_from_long (FD_CLOEXEC));
scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC));
#endif
#include "libguile/filesys.x"

4
libguile/gc.c
View file

@ -223,6 +223,7 @@ unsigned long scm_mtrigger;
/* GC Statistics Keeping
*/
unsigned long scm_cells_allocated = 0;
unsigned long scm_last_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 */
@ -256,8 +257,7 @@ SCM_SYMBOL (sym_cells_swept, "cells-swept");
SCM_SYMBOL (sym_malloc_yield, "malloc-yield");
SCM_SYMBOL (sym_cell_yield, "cell-yield");
SCM_SYMBOL (sym_protected_objects, "protected-objects");
SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated");
/* Number of calls to SCM_NEWCELL since startup. */

2
libguile/gsubr.c
View file

@ -24,6 +24,8 @@
#include "libguile/gsubr.h"
#include "libguile/deprecation.h"
#include "libguile/private-options.h"
/*
* gsubr.c

864
libguile/i18n.c
View file

File diff suppressed because it is too large Load diff

2
libguile/i18n.h
View file

@ -22,6 +22,7 @@
#include "libguile/__scm.h"
SCM_API SCM scm_global_locale;
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);
@ -40,6 +41,7 @@ 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 SCM scm_nl_langinfo (SCM item, SCM locale);
SCM_API void scm_init_i18n (void);

1
libguile/init.c
View file

@ -127,6 +127,7 @@
#include "libguile/deprecated.h"
#include "libguile/init.h"
#include "libguile/private-options.h"
#ifdef HAVE_STRING_H
#include <string.h>

2
libguile/macros.c
View file

@ -30,6 +30,8 @@
#include "libguile/validate.h"
#include "libguile/macros.h"
#include "libguile/private-options.h"
scm_t_bits scm_tc16_macro;

61
libguile/numbers.c
View file

@ -452,28 +452,21 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
/* No, it's a proper fraction.
*/
return scm_double_cell (scm_tc16_fraction,
SCM_UNPACK (numerator),
SCM_UNPACK (denominator), 0);
{
SCM divisor = scm_gcd (numerator, denominator);
if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1))))
{
numerator = scm_divide (numerator, divisor);
denominator = scm_divide (denominator, divisor);
}
return scm_double_cell (scm_tc16_fraction,
SCM_UNPACK (numerator),
SCM_UNPACK (denominator), 0);
}
}
#undef FUNC_NAME
static void scm_i_fraction_reduce (SCM z)
{
if (!(SCM_FRACTION_REDUCED (z)))
{
SCM divisor;
divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z));
if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1))))
{
/* is this safe? */
SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor));
SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor));
}
SCM_FRACTION_REDUCED_SET (z);
}
}
double
scm_i_fraction2double (SCM z)
{
@ -2387,7 +2380,6 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
}
else if (SCM_FRACTIONP (n))
{
scm_i_fraction_reduce (n);
return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
scm_from_locale_string ("/"),
scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
@ -2441,7 +2433,6 @@ int
scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
SCM str;
scm_i_fraction_reduce (sexp);
str = scm_number_to_string (sexp, SCM_UNDEFINED);
scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port);
scm_remember_upto_here_1 (str);
@ -3109,8 +3100,6 @@ scm_complex_equalp (SCM x, SCM y)
SCM
scm_i_fraction_equalp (SCM x, SCM y)
{
scm_i_fraction_reduce (x);
scm_i_fraction_reduce (y);
if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_NUMERATOR (y)))
|| scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
@ -4492,7 +4481,12 @@ scm_product (SCM x, SCM y)
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x));
{
/* inexact*exact0 => exact 0, per R5RS "Exactness" section */
if (scm_is_eq (y, SCM_INUM0))
return y;
return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x));
}
else if (SCM_BIGP (y))
{
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
@ -4512,8 +4506,13 @@ scm_product (SCM x, SCM y)
else if (SCM_COMPLEXP (x))
{
if (SCM_I_INUMP (y))
return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x),
SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x));
{
/* inexact*exact0 => exact 0, per R5RS "Exactness" section */
if (scm_is_eq (y, SCM_INUM0))
return y;
return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x),
SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x));
}
else if (SCM_BIGP (y))
{
double z = mpz_get_d (SCM_I_BIG_MPZ (y));
@ -5425,10 +5424,7 @@ scm_numerator (SCM z)
else if (SCM_BIGP (z))
return z;
else if (SCM_FRACTIONP (z))
{
scm_i_fraction_reduce (z);
return SCM_FRACTION_NUMERATOR (z);
}
return SCM_FRACTION_NUMERATOR (z);
else if (SCM_REALP (z))
return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
else
@ -5447,10 +5443,7 @@ scm_denominator (SCM z)
else if (SCM_BIGP (z))
return SCM_I_MAKINUM (1);
else if (SCM_FRACTIONP (z))
{
scm_i_fraction_reduce (z);
return SCM_FRACTION_DENOMINATOR (z);
}
return SCM_FRACTION_DENOMINATOR (z);
else if (SCM_REALP (z))
return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
else

8
libguile/numbers.h
View file

@ -157,14 +157,6 @@
#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x))
#define SCM_FRACTION_SET_NUMERATOR(x, v) (SCM_SET_CELL_OBJECT_1 ((x), (v)))
#define SCM_FRACTION_SET_DENOMINATOR(x, v) (SCM_SET_CELL_OBJECT_2 ((x), (v)))
/* I think the left half word is free in the type, so I'll use bit 17 */
#define SCM_FRACTION_REDUCED_BIT 0x10000
#define SCM_FRACTION_REDUCED_SET(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) | SCM_FRACTION_REDUCED_BIT)))
#define SCM_FRACTION_REDUCED_CLEAR(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) & ~SCM_FRACTION_REDUCED_BIT)))
#define SCM_FRACTION_REDUCED(x) (0x10000 & SCM_CELL_TYPE (x))

59
libguile/options.c
View file

@ -95,11 +95,11 @@ static SCM protected_objects = SCM_EOL;
/* Return a list of the current option setting. The format of an
* option setting is described in the above documentation. */
static SCM
get_option_setting (const scm_t_option options[], unsigned int n)
get_option_setting (const scm_t_option options[])
{
unsigned int i;
SCM ls = SCM_EOL;
for (i = 0; i != n; ++i)
for (i = 0; options[i].name; ++i)
{
switch (options[i].type)
{
@ -123,12 +123,12 @@ get_option_setting (const scm_t_option options[], unsigned int n)
/* Return a list of sublists, where each sublist contains option name, value
* and documentation string. */
static SCM
get_documented_option_setting (const scm_t_option options[], unsigned int n)
get_documented_option_setting (const scm_t_option options[])
{
SCM ans = SCM_EOL;
unsigned int i;
for (i = 0; i != n; ++i)
for (i = 0; options[i].name; ++i)
{
SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL);
switch (options[i].type)
@ -149,21 +149,36 @@ get_documented_option_setting (const scm_t_option options[], unsigned int n)
}
static int
options_length (scm_t_option options[])
{
unsigned int i = 0;
for (; options[i].name != NULL; ++i)
;
return i;
}
/* Alters options according to the given option setting 'args'. The value of
* args is known to be a list, but it is not known whether the list is a well
* formed option setting, i. e. if for every non-boolean option a value is
* given. For this reason, the function applies all changes to a copy of the
* original setting in memory. Only if 'args' was successfully processed,
* the new setting will overwrite the old one. */
* the new setting will overwrite the old one.
*
* If DRY_RUN is set, don't change anything. This is useful for trying out an option
* before entering a critical section.
*/
static void
change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s)
change_option_setting (SCM args, scm_t_option options[], const char *s,
int dry_run)
{
unsigned int i;
SCM locally_protected_args = args;
SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits));
SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits));
scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
for (i = 0; i != n; ++i)
for (i = 0; options[i].name; ++i)
{
if (options[i].type == SCM_OPTION_BOOLEAN)
flags[i] = 0;
@ -176,7 +191,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c
SCM name = SCM_CAR (args);
int found = 0;
for (i = 0; i != n && !found; ++i)
for (i = 0; options[i].name && !found; ++i)
{
if (scm_is_eq (name, SCM_PACK (options[i].name)))
{
@ -204,7 +219,10 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c
args = SCM_CDR (args);
}
for (i = 0; i != n; ++i)
if (dry_run)
return;
for (i = 0; options[i].name; ++i)
{
if (options[i].type == SCM_OPTION_SCM)
{
@ -223,32 +241,39 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c
SCM
scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s)
scm_options (SCM args, scm_t_option options[], const char *s)
{
return scm_options_try (args, options, s, 0);
}
SCM
scm_options_try (SCM args, scm_t_option options[], const char *s,
int dry_run)
{
if (SCM_UNBNDP (args))
return get_option_setting (options, n);
return get_option_setting (options);
else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args))
/* Dirk:FIXME:: This criterion should be improved. IMO it is better to
* demand that args is #t if documentation should be shown than to say
* that every argument except a list will print out documentation. */
return get_documented_option_setting (options, n);
return get_documented_option_setting (options);
else
{
SCM old_setting;
SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
old_setting = get_option_setting (options, n);
change_option_setting (args, options, n, s);
old_setting = get_option_setting (options);
change_option_setting (args, options, s, dry_run);
return old_setting;
}
}
void
scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n)
scm_init_opts (SCM (*func) (SCM), scm_t_option options[])
{
unsigned int i;
for (i = 0; i != n; ++i)
for (i = 0; options[i].name; ++i)
{
SCM name = scm_from_locale_symbol (options[i].name);
options[i].name = (char *) SCM_UNPACK (name);

5
libguile/options.h
View file

@ -40,8 +40,9 @@ typedef struct scm_t_option
#define SCM_OPTION_SCM 2
SCM_API SCM scm_options (SCM, scm_t_option [], unsigned int, const char*);
SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option [], unsigned int n);
SCM_API SCM scm_options_try (SCM args, scm_t_option options[], const char *s, int dry_run);
SCM_API SCM scm_options (SCM, scm_t_option [], const char*);
SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option []);
SCM_API void scm_init_options (void);
#endif /* SCM_OPTIONS_H */

101
libguile/posix.c
View file

@ -119,6 +119,10 @@ extern char ** environ;
# define USE_GNU_LOCALE_API
#endif
#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
# include <xlocale.h>
#endif
#if HAVE_CRYPT_H
# include <crypt.h>
#endif
@ -491,11 +495,25 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
/* Signal values are interned in scm_init_posix(). */
#ifdef HAVE_KILL
if (kill (scm_to_int (pid), scm_to_int (sig)) != 0)
SCM_SYSERROR;
#else
/* Mingw has raise(), but not kill(). (Other raw DOS environments might
be similar.) Use raise() when the requested pid is our own process,
otherwise bomb. */
if (scm_to_int (pid) == getpid ())
if (raise (scm_to_int (sig)) != 0)
{
if (raise (scm_to_int (sig)) != 0)
{
err:
SCM_SYSERROR;
}
else
{
errno = ENOSYS;
goto err;
}
}
#endif
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -1316,9 +1334,6 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
{
int rv;
char *c_str = scm_to_locale_string (str);
#ifdef __MINGW32__
size_t len = strlen (c_str);
#endif
if (strchr (c_str, '=') == NULL)
{
@ -1333,6 +1348,7 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
/* On e.g. Win32 hosts putenv() called with 'name=' removes the
environment variable 'name'. */
int e;
size_t len = strlen (c_str);
char *ptr = scm_malloc (len + 2);
strcpy (ptr, c_str);
strcpy (ptr+len, "=");
@ -1352,26 +1368,29 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
by getenv. It's not enough just to modify the string we set,
because MINGW putenv copies it. */
if (c_str[len-1] == '=')
{
char *ptr = scm_malloc (len+2);
strcpy (ptr, c_str);
strcpy (ptr+len, " ");
rv = putenv (ptr);
if (rv < 0)
{
int eno = errno;
free (c_str);
errno = eno;
SCM_SYSERROR;
}
/* truncate to just the name */
c_str[len-1] = '\0';
ptr = getenv (c_str);
if (ptr)
ptr[0] = '\0';
return SCM_UNSPECIFIED;
}
{
size_t len = strlen (c_str);
if (c_str[len-1] == '=')
{
char *ptr = scm_malloc (len+2);
strcpy (ptr, c_str);
strcpy (ptr+len, " ");
rv = putenv (ptr);
if (rv < 0)
{
int eno = errno;
free (c_str);
errno = eno;
SCM_SYSERROR;
}
/* truncate to just the name */
c_str[len-1] = '\0';
ptr = getenv (c_str);
if (ptr)
ptr[0] = '\0';
return SCM_UNSPECIFIED;
}
}
#endif /* __MINGW32__ */
/* Leave c_str in the environment. */
@ -1384,12 +1403,11 @@ 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
systems (i.e., systems where a reentrant locale API is not available). It
is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for
details. */
scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef HAVE_SETLOCALE
@ -1406,6 +1424,7 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
"the locale will be set using environment variables.")
#define FUNC_NAME s_scm_setlocale
{
int c_category;
char *clocale;
char *rv;
@ -1421,13 +1440,11 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
scm_dynwind_free (clocale);
}
#ifndef USE_GNU_LOCALE_API
c_category = scm_i_to_lc_category (category, 1);
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
rv = setlocale (c_category, clocale);
scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
#endif
if (rv == NULL)
{
@ -1565,7 +1582,7 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
#define FUNC_NAME s_scm_crypt
{
SCM ret;
char *c_key, *c_salt;
char *c_key, *c_salt, *c_ret;
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
@ -1575,8 +1592,14 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
c_salt = scm_to_locale_string (salt);
scm_dynwind_free (c_salt);
ret = scm_from_locale_string (crypt (c_key, c_salt));
/* The Linux crypt(3) man page says crypt will return NULL and set errno
on error. (Eg. ENOSYS if legal restrictions mean it cannot be
implemented). */
c_ret = crypt (c_key, c_salt);
if (c_ret == NULL)
SCM_SYSERROR;
ret = scm_from_locale_string (c_ret);
scm_dynwind_end ();
return ret;
}
@ -1965,10 +1988,6 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
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");

16
libguile/print.c
View file

@ -43,6 +43,9 @@
#include "libguile/validate.h"
#include "libguile/print.h"
#include "libguile/private-options.h"
/* {Names of immediate symbols}
@ -83,7 +86,9 @@ scm_t_option scm_print_opts[] = {
"How to print symbols that have a colon as their first or last character. "
"The value '#f' does not quote the colons; '#t' quotes them; "
"'reader' quotes them when the reader option 'keywords' is not '#f'."
}
},
{ 0 },
};
SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
@ -96,7 +101,6 @@ SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
{
SCM ans = scm_options (setting,
scm_print_opts,
SCM_N_PRINT_OPTIONS,
FUNC_NAME);
return ans;
}
@ -940,11 +944,13 @@ scm_write (SCM obj, SCM port)
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
scm_prin1 (obj, port, 1);
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
scm_close_port (port);
# endif
#endif
#endif
return SCM_UNSPECIFIED;
}
@ -961,11 +967,13 @@ scm_display (SCM obj, SCM port)
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
scm_prin1 (obj, port, 0);
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
scm_close_port (port);
# endif
#endif
#endif
return SCM_UNSPECIFIED;
}
@ -1098,11 +1106,13 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
SCM_VALIDATE_OPORT_VALUE (2, port);
scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
scm_close_port (port);
# endif
#endif
#endif
return SCM_UNSPECIFIED;
}
@ -1173,7 +1183,7 @@ scm_init_print ()
{
SCM vtable, layout, type;
scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
scm_init_opts (scm_print_options, scm_print_opts);
scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"),
scm_from_locale_string ("{"),

9
libguile/print.h
View file

@ -26,15 +26,6 @@
#include "libguile/options.h"
SCM_API scm_t_option scm_print_opts[];
#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val))
#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[2].val))
#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[3].val))
#define SCM_PRINT_KEYWORD_STYLE_I 4
#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[4].val))
#define SCM_N_PRINT_OPTIONS 5
/* State information passed around during printing.
*/

21
libguile/private-gc.h
View file

@ -1,7 +1,22 @@
/*
(c) FSF 2002.
*/
* private-gc.h - private declarations for garbage collection.
*
* Copyright (C) 2002, 03, 04, 05, 06, 07 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
*/
#ifndef PRIVATE_GC
#define PRIVATE_GC

103
libguile/private-options.h Normal file
View file

@ -0,0 +1,103 @@
/*
* private-options.h - private declarations for option handling
*
* We put this in a private header, since layout of data structures
* is an implementation detail that we want to hide.
*
* Copyright (C) 2007 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
*/
#ifndef PRIVATE_OPTIONS
#define PRIVATE_OPTIONS
/*
evaluator
*/
SCM_API scm_t_option scm_eval_opts[];
SCM_API long scm_eval_stack;
SCM_API scm_t_option scm_evaluator_trap_table[];
SCM_API SCM scm_eval_options_interface (SCM setting);
#define SCM_EVAL_STACK scm_eval_opts[0].val
#define SCM_TRAPS_P scm_evaluator_trap_table[0].val
#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val
#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val
#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val
#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val))
#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val))
#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val))
#define SCM_MEMOIZE_P scm_evaluator_trap_table[7].val
#define SCM_MEMOIZE_HDLR (SCM_PACK (scm_evaluator_trap_table[8].val))
/*
debugging.
*/
SCM_API scm_t_option scm_debug_opts[];
#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
#define SCM_TRACE_P scm_debug_opts[2].val
#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
#define SCM_BACKWARDS_P scm_debug_opts[4].val
#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val
#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val
#define SCM_N_FRAMES scm_debug_opts[7].val
#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val
#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val
#define SCM_BACKTRACE_P scm_debug_opts[10].val
#define SCM_DEVAL_P scm_debug_opts[11].val
#define SCM_STACK_LIMIT scm_debug_opts[12].val
#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val
#define SCM_WARN_DEPRECATED scm_debug_opts[14].val
#define SCM_N_DEBUG_OPTIONS 15
/*
printing
*/
SCM_API scm_t_option scm_print_opts[];
#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val))
#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[2].val))
#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[3].val))
#define SCM_PRINT_KEYWORD_STYLE_I 4
#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[4].val))
#define SCM_N_PRINT_OPTIONS 5
/*
read
*/
SCM_API scm_t_option scm_read_opts[];
#define SCM_COPY_SOURCE_P scm_read_opts[0].val
#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
#define SCM_KEYWORD_STYLE scm_read_opts[3].val
#if SCM_ENABLE_ELISP
#define SCM_ELISP_VECTORS_P scm_read_opts[4].val
#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val
#define SCM_N_READ_OPTIONS 6
#else
#define SCM_N_READ_OPTIONS 4
#endif
#endif /* PRIVATE_OPTIONS */

15
libguile/read.c
View file

@ -38,6 +38,8 @@
#include "libguile/srfi-4.h"
#include "libguile/read.h"
#include "libguile/private-options.h"
@ -52,14 +54,14 @@ scm_t_option scm_read_opts[] = {
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0,
"Convert symbols to lower case."},
{ SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
"Style of keyword recognition: #f or 'prefix."}
"Style of keyword recognition: #f or 'prefix."},
#if SCM_ENABLE_ELISP
,
{ SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
"Support Elisp vector syntax, namely `[...]'."},
{ SCM_OPTION_BOOLEAN, "elisp-strings", 0,
"Support `\\(' and `\\)' in strings."}
"Support `\\(' and `\\)' in strings."},
#endif
{ 0, },
};
/*
@ -112,7 +114,6 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
{
SCM ans = scm_options (setting,
scm_read_opts,
SCM_N_READ_OPTIONS,
FUNC_NAME);
if (SCM_COPY_SOURCE_P)
SCM_RECORD_POSITIONS_P = 1;
@ -898,7 +899,9 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
"starting with the character sequence @code{#} and @var{chr}.\n"
"@var{proc} will be called with two arguments: the character\n"
"@var{chr} and the port to read further data from. The object\n"
"returned will be the return value of @code{read}.")
"returned will be the return value of @code{read}. \n"
"Passing @code{#f} for @var{proc} will remove a previous setting. \n"
)
#define FUNC_NAME s_scm_read_hash_extend
{
SCM this;
@ -977,7 +980,7 @@ scm_init_read ()
scm_read_hash_procedures =
SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));
scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
scm_init_opts (scm_read_options, scm_read_opts);
#include "libguile/read.x"
}

12
libguile/read.h
View file

@ -45,19 +45,7 @@
#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t'
SCM_API scm_t_option scm_read_opts[];
#define SCM_COPY_SOURCE_P scm_read_opts[0].val
#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
#define SCM_KEYWORD_STYLE scm_read_opts[3].val
#if SCM_ENABLE_ELISP
#define SCM_ELISP_VECTORS_P scm_read_opts[4].val
#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val
#define SCM_N_READ_OPTIONS 6
#else
#define SCM_N_READ_OPTIONS 4
#endif

27
libguile/regex-posix.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 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
@ -218,6 +218,17 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
"@end table")
#define FUNC_NAME s_scm_regexp_exec
{
/* We used to have an SCM_DEFER_INTS, and then later an
SCM_CRITICAL_SECTION_START, around the regexec() call. Can't quite
remember what defer ints was for, but a critical section would only be
wanted now if we think regexec() is not thread-safe. The posix spec
http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html
reads like regexec is meant to be both thread safe and reentrant
(mentioning simultaneous use in threads, and in signal handlers). So
for now believe no protection needed. */
int status, nmatches, offset;
regmatch_t *matches;
char *c_str;
@ -245,7 +256,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
whole regexp, so add 1 to nmatches. */
nmatches = SCM_RGX(rx)->re_nsub + 1;
SCM_CRITICAL_SECTION_START;
matches = scm_malloc (sizeof (regmatch_t) * nmatches);
c_str = scm_to_locale_string (substr);
status = regexec (SCM_RGX (rx), c_str, nmatches, matches,
@ -269,7 +279,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
scm_from_long (matches[i].rm_eo + offset)));
}
free (matches);
SCM_CRITICAL_SECTION_END;
if (status != 0 && status != REG_NOMATCH)
scm_error_scm (scm_regexp_error_key,
@ -287,14 +296,14 @@ scm_init_regex_posix ()
scm_set_smob_free (scm_tc16_regex, regex_free);
/* Compilation flags. */
scm_c_define ("regexp/basic", scm_from_long (REG_BASIC));
scm_c_define ("regexp/extended", scm_from_long (REG_EXTENDED));
scm_c_define ("regexp/icase", scm_from_long (REG_ICASE));
scm_c_define ("regexp/newline", scm_from_long (REG_NEWLINE));
scm_c_define ("regexp/basic", scm_from_int (REG_BASIC));
scm_c_define ("regexp/extended", scm_from_int (REG_EXTENDED));
scm_c_define ("regexp/icase", scm_from_int (REG_ICASE));
scm_c_define ("regexp/newline", scm_from_int (REG_NEWLINE));
/* Execution flags. */
scm_c_define ("regexp/notbol", scm_from_long (REG_NOTBOL));
scm_c_define ("regexp/noteol", scm_from_long (REG_NOTEOL));
scm_c_define ("regexp/notbol", scm_from_int (REG_NOTBOL));
scm_c_define ("regexp/noteol", scm_from_int (REG_NOTEOL));
#include "libguile/regex-posix.x"

24
libguile/scmsigs.c
View file

@ -22,6 +22,7 @@
# include <config.h>
#endif
#include <fcntl.h> /* for mingw */
#include <signal.h>
#include <stdio.h>
#include <errno.h>
@ -36,6 +37,14 @@
#include "libguile/validate.h"
#include "libguile/scmsigs.h"
#ifdef HAVE_IO_H
#include <io.h> /* for mingw _pipe() */
#endif
#ifdef HAVE_PROCESS_H
#include <process.h> /* for mingw */
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@ -50,7 +59,7 @@
/* This weird comma expression is because Sleep is void under Windows. */
#define sleep(sec) (Sleep ((sec) * 1000), 0)
#define usleep(usec) (Sleep ((usec) / 1000), 0)
#define kill(pid, sig) raise (sig)
#define pipe(fd) _pipe (fd, 256, O_BINARY)
#endif
@ -106,6 +115,12 @@ close_1 (SCM proc, SCM arg)
}
#if SCM_USE_PTHREAD_THREADS
/* On mingw there's no notion of inter-process signals, only a raise()
within the process itself which apparently invokes the registered handler
immediately. Not sure how well the following code will cope in this
case. It builds but it may not offer quite the same scheme-level
semantics as on a proper system. If you're relying on much in the way of
signal handling on mingw you probably lose anyway. */
static int signal_pipe[2];
@ -149,12 +164,13 @@ read_without_guile (int fd, char *buf, size_t n)
static SCM
signal_delivery_thread (void *data)
{
sigset_t all_sigs;
int n, sig;
char sigbyte;
#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */
sigset_t all_sigs;
sigfillset (&all_sigs);
scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
#endif
while (1)
{
@ -616,7 +632,7 @@ SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
"@var{sig} is as described for the kill procedure.")
#define FUNC_NAME s_scm_raise
{
if (kill (getpid (), scm_to_int (sig)) != 0)
if (raise (scm_to_int (sig)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}

104
libguile/srcprop.c
View file

@ -38,7 +38,7 @@
/* {Source Properties}
*
* Properties of source list expressions.
* Five of these have special meaning and optimized storage:
* Five of these have special meaning:
*
* filename string The name of the source file.
* copy list A copy of the list expression.
@ -56,8 +56,46 @@ SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
/*
* Source properties are stored as double cells with the
* following layout:
* car = tag
* cbr = pos
* ccr = copy
* cdr = plist
*/
#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
#define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p))
#define SETSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
#define CLEARSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
scm_t_bits scm_tc16_srcprops;
static SCM
srcprops_mark (SCM obj)
{
scm_gc_mark (SRCPROPCOPY (obj));
return SRCPROPPLIST (obj);
}
static int
srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
@ -80,19 +118,45 @@ scm_c_source_property_breakpoint_p (SCM form)
}
/*
* We remember the last file name settings, so we can share that plist
* entry. This works because scm_set_source_property_x does not use
* assoc-set! for modifying the plist.
*
* This variable contains a protected cons, whose cdr is the cached
* plist
*/
static SCM scm_last_plist_filename;
SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
{
register scm_t_srcprops *ptr;
if (!SCM_UNBNDP (filename))
{
SCM old_plist = plist;
ptr = scm_gc_malloc (sizeof (*ptr), "srcprop");
ptr->pos = SRCPROPMAKPOS (line, col);
ptr->fname = filename;
ptr->copy = copy;
ptr->plist = plist;
SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
/*
have to extract the acons, and operate on that, for
thread safety.
*/
SCM last_acons = SCM_CDR (scm_last_plist_filename);
if (old_plist == SCM_EOL
&& SCM_CDAR (last_acons) == filename)
{
plist = last_acons;
}
else
{
plist = scm_acons (scm_sym_filename, filename, plist);
if (old_plist == SCM_EOL)
SCM_SETCDR (scm_last_plist_filename, plist);
}
}
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col),
copy,
plist);
}
@ -102,8 +166,6 @@ scm_srcprops_to_plist (SCM obj)
SCM plist = SRCPROPPLIST (obj);
if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist);
plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist);
plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist);
plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist);
@ -168,7 +230,6 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p));
else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p));
else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p));
else if (scm_is_eq (scm_sym_filename, key)) p = SRCPROPFNAME (p);
else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p);
else
{
@ -239,13 +300,6 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
scm_make_srcprops (0, scm_to_int (datum),
SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_filename, key))
{
if (SRCPROPSP (p))
SRCPROPFNAME (p) = datum;
else
SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_copy, key))
{
if (SRCPROPSP (p))
@ -269,19 +323,19 @@ void
scm_init_srcprop ()
{
scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark);
scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
scm_c_define ("source-whash", scm_source_whash);
scm_last_plist_filename
= scm_permanent_object (scm_cons (SCM_EOL,
scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
#include "libguile/srcprop.x"
}
void
scm_finish_srcprop ()
{
/* Nothing to do. */
}
/*
Local Variables:

34
libguile/srcprop.h
View file

@ -49,40 +49,10 @@ do { \
/* {Source properties}
*/
SCM_API scm_t_bits scm_tc16_srcprops;
typedef struct scm_t_srcprops
{
unsigned long pos;
SCM fname;
SCM copy;
SCM plist;
} scm_t_srcprops;
#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
#define SRCPROPPOS(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->pos
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
#define SRCPROPFNAME(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->fname
#define SRCPROPCOPY(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->copy
#define SRCPROPPLIST(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->plist
#define SETSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
#define CLEARSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
#define SETSRCPROPPOS(p, l, c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c))
#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
#define PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
SCM_API scm_t_bits scm_tc16_srcprops;
SCM_API SCM scm_sym_filename;
SCM_API SCM scm_sym_copy;

2
libguile/stacks.c
View file

@ -32,6 +32,8 @@
#include "libguile/validate.h"
#include "libguile/stacks.h"
#include "libguile/private-options.h"
/* {Frames and stacks}

9
libguile/struct.c
View file

@ -540,10 +540,15 @@ scm_i_struct_equalp (SCM s1, SCM s2)
field1 = scm_struct_ref (s1, s_field_num);
field2 = scm_struct_ref (s2, s_field_num);
if (scm_is_false (scm_equal_p (field1, field2)))
return SCM_BOOL_F;
/* Self-referencing fields (type `s') must be skipped to avoid infinite
recursion. */
if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
if (scm_is_false (scm_equal_p (field1, field2)))
return SCM_BOOL_F;
}
/* FIXME: Tail elements should be tested for equality. */
return SCM_BOOL_T;
}
#undef FUNC_NAME

3
libguile/symbols.c
View file

@ -40,6 +40,9 @@
#include "libguile/validate.h"
#include "libguile/symbols.h"
#include "libguile/private-options.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif

56
libguile/threads.c
View file

@ -131,9 +131,32 @@ dequeue (SCM q)
static int
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
/* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
struct. A cast like "(unsigned long) t->pthread" is a syntax error in
the struct case, hence we go via a union, and extract according to the
size of pthread_t. */
union {
scm_i_pthread_t p;
unsigned short us;
unsigned int ui;
unsigned long ul;
scm_t_uintmax um;
} u;
scm_i_thread *t = SCM_I_THREAD_DATA (exp);
scm_i_pthread_t p = t->pthread;
scm_t_uintmax id;
u.p = p;
if (sizeof (p) == sizeof (unsigned short))
id = u.us;
else if (sizeof (p) == sizeof (unsigned int))
id = u.ui;
else if (sizeof (p) == sizeof (unsigned long))
id = u.ul;
else
id = u.um;
scm_puts ("#<thread ", port);
scm_uintprint ((size_t)t->pthread, 10, port);
scm_uintprint (id, 10, port);
scm_puts (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
scm_puts (")>", port);
@ -563,9 +586,11 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
}
#if SCM_USE_PTHREAD_THREADS
/* pthread_getattr_np not available on MacOS X and Solaris 10. */
#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
/* This method for GNU/Linux and perhaps some other systems.
It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
available on them. */
#define HAVE_GET_THREAD_STACK_BASE
static SCM_STACKITEM *
@ -598,7 +623,30 @@ get_thread_stack_base ()
}
}
#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */
#elif HAVE_PTHREAD_GET_STACKADDR_NP
/* This method for MacOS X.
It'd be nice if there was some documentation on pthread_get_stackaddr_np,
but as of 2006 there's nothing obvious at apple.com. */
#define HAVE_GET_THREAD_STACK_BASE
static SCM_STACKITEM *
get_thread_stack_base ()
{
return pthread_get_stackaddr_np (pthread_self ());
}
#elif defined (__MINGW32__)
/* This method for mingw. In mingw the basic scm_get_stack_base can be used
in any thread. We don't like hard-coding the name of a system, but there
doesn't seem to be a cleaner way of knowing scm_get_stack_base can
work. */
#define HAVE_GET_THREAD_STACK_BASE
static SCM_STACKITEM *
get_thread_stack_base ()
{
return scm_get_stack_base ();
}
#endif /* pthread methods of get_thread_stack_base */
#else /* !SCM_USE_PTHREAD_THREADS */

28
libguile/throw.c
View file

@ -37,6 +37,10 @@
#include "libguile/validate.h"
#include "libguile/throw.h"
#include "libguile/init.h"
#include "libguile/strings.h"
#include "libguile/private-options.h"
/* the jump buffer data structure */
@ -695,7 +699,31 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
if (scm_i_critical_section_level)
{
SCM s = args;
int i = 0;
/*
We have much better routines for displaying Scheme, but we're
already inside a pernicious error, and it's unlikely that they
are available to us. We try to print something useful anyway,
so users don't need a debugger to find out what went wrong.
*/
fprintf (stderr, "throw from within critical section.\n");
if (scm_is_symbol (key))
fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key));
for (; scm_is_pair (s); s = scm_cdr (s), i++)
{
char const *str = NULL;
if (scm_is_string (scm_car (s)))
str = scm_i_string_chars (scm_car (s));
else if (scm_is_symbol (scm_car (s)))
str = scm_i_symbol_chars (scm_car (s));
if (str != NULL)
fprintf (stderr, "argument %d: %s\n", i, str);
}
abort ();
}

12
libguile/version.h.in
View file

@ -30,12 +30,12 @@
#define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@
#define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@
extern SCM scm_major_version (void);
extern SCM scm_minor_version (void);
extern SCM scm_micro_version (void);
extern SCM scm_effective_version (void);
extern SCM scm_version (void);
extern void scm_init_version (void);
SCM_API SCM scm_major_version (void);
SCM_API SCM scm_minor_version (void);
SCM_API SCM scm_micro_version (void);
SCM_API SCM scm_effective_version (void);
SCM_API SCM scm_version (void);
SCM_API void scm_init_version (void);
#endif /* SCM_VERSION_H */

43
srfi/ChangeLog
View file

@ -1,3 +1,34 @@
2007-02-04 Ludovic Courtès <ludovic.courtes@laas.fr>
* srfi/srfi-19.scm (priv:locale-abbr-weekday): Add one to the day
number before invoking `locale-day-short'. Failing to do so
resulted in days shifted by one in the result of `date->string',
or in the failure of `date->string' when the day is zero.
(priv:locale-long-weekday): Likewise.
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* srfi-19.scm: Use `(ice-9 i18n)'.
(priv:locale-abbr-weekday-vector, priv:locale-long-weekday-vector,
priv:locale-abbr-month-vector, priv:locale-long-month-vector):
Removed.
(priv:locale-number-separator, priv:locale-pm, priv:locale-am,
priv:locale-abbr-weekday, priv:locale-long-weekday,
priv:locale-abbr-month, priv:locale-long-month): Aliases for their
respective `(ice-9 i18n)' equivalent.
(priv:vector-find): Removed, replaced by...
(priv:date-reverse-lookup): New procedure. Updated callers.
(priv:locale-am/pm): Use `priv:locale-pm' and `priv:locale-am' as
procedures.
(priv:directives): Use `priv:locale-number-separator' as a
procedure.
2006-12-02 Kevin Ryde <user42@zip.com.au>
* srfi-60.c (scm_srfi60_copy_bit): Should be long not int for fixnum
bitshift, fixes 64-bit systems setting a bit between 32 and 63.
Reported by Aaron M. Ucko, Debian bug 396119.
2006-05-28 Kevin Ryde <user42@zip.com.au>
* srfi-1.scm, srfi-1.c, srfi-1.h (append-reverse, append-reverse!):
@ -282,7 +313,7 @@
2004-08-02 Kevin Ryde <user42@zip.com.au>
* srfi-13.c (scm_string_every): Correction to initial "res" value,
return should be #t for an empty string. Reported by Andreas Vögele.
return should be #t for an empty string. Reported by Andreas Vögele.
2004-07-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
@ -505,7 +536,7 @@
* srfi-14.h (SCM_CHARSET_GET): Cast IDX to unsigned char so that
it works for 8-bit characters. Thanks to Matthias Koeppe! No,
make that "Köppe".
make that "Köppe".
2002-04-24 Marius Vollmer <mvo@zagadka.ping.de>
@ -558,7 +589,7 @@
2002-02-22 Neil Jerram <neil@ossau.uklinux.net>
* srfi-19.scm (priv:year-day): Index into priv:month-assoc using
month number, not day number. (Thanks to Sébastien de Menten de
month number, not day number. (Thanks to Sébastien de Menten de
Horne for reporting the problem.)
2002-02-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
@ -977,7 +1008,7 @@
2001-05-28 Michael Livshin <mlivshin@bigfoot.com>
* srfi-19.scm: removed a stray open parenthesis. (thanks to
Matthias Köppe for the report).
Matthias Köppe for the report).
2001-05-23 Rob Browning <rlb@cs.utexas.edu>
@ -1233,3 +1264,7 @@
* Started guile-srfi-13 package. Files are copied from the
guile-gdbm and slightly modified.
;; Local Variables:
;; coding: utf-8
;; End:

95
srfi/srfi-19.scm
View file

@ -41,7 +41,8 @@
(define-module (srfi srfi-19)
:use-module (srfi srfi-6)
:use-module (srfi srfi-8)
:use-module (srfi srfi-9))
:use-module (srfi srfi-9)
:use-module (ice-9 i18n))
(begin-deprecated
;; Prevent `export' from re-exporting core bindings. This behaviour
@ -150,48 +151,9 @@
;;-- LOCALE dependent constants
(define priv:locale-number-separator ".")
(define priv:locale-abbr-weekday-vector
(vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
(define priv:locale-long-weekday-vector
(vector
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
;; note empty string in 0th place.
(define priv:locale-abbr-month-vector
(vector ""
"Jan"
"Feb"
"Mar"
"Apr"
"May"
"Jun"
"Jul"
"Aug"
"Sep"
"Oct"
"Nov"
"Dec"))
(define priv:locale-long-month-vector
(vector ""
"January"
"February"
"March"
"April"
"May"
"June"
"July"
"August"
"September"
"October"
"November"
"December"))
(define priv:locale-pm "PM")
(define priv:locale-am "AM")
(define priv:locale-number-separator locale-decimal-point)
(define priv:locale-pm locale-pm-string)
(define priv:locale-am locale-am-string)
;; See date->string
(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
@ -964,38 +926,33 @@
(define (priv:last-n-digits i n)
(abs (remainder i (expt 10 n))))
(define (priv:locale-abbr-weekday n)
(vector-ref priv:locale-abbr-weekday-vector n))
(define (priv:locale-abbr-weekday n) (locale-day-short (+ 1 n)))
(define (priv:locale-long-weekday n) (locale-day (+ 1 n)))
(define priv:locale-abbr-month locale-month-short)
(define priv:locale-long-month locale-month)
(define (priv:locale-long-weekday n)
(vector-ref priv:locale-long-weekday-vector n))
(define (priv:locale-abbr-month n)
(vector-ref priv:locale-abbr-month-vector n))
(define (priv:locale-long-month n)
(vector-ref priv:locale-long-month-vector n))
(define (priv:vector-find needle haystack comparator)
(let ((len (vector-length haystack)))
(define (priv:vector-find-int index)
(cond
((>= index len) #f)
((comparator needle (vector-ref haystack index)) index)
(else (priv:vector-find-int (+ index 1)))))
(priv:vector-find-int 0)))
(define (priv:date-reverse-lookup needle haystack-ref haystack-len
same?)
;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure
;; that returns a string corresponding to the given index) by passing it
;; indices lower than HAYSTACK-LEN.
(let loop ((index 1))
(cond ((> index haystack-len) #f)
((same? needle (haystack-ref index))
index)
(else (loop (+ index 1))))))
(define (priv:locale-abbr-weekday->index string)
(priv:vector-find string priv:locale-abbr-weekday-vector string=?))
(priv:date-reverse-lookup string priv:locale-abbr-weekday 7 string=?))
(define (priv:locale-long-weekday->index string)
(priv:vector-find string priv:locale-long-weekday-vector string=?))
(priv:date-reverse-lookup string priv:locale-long-weekday 7 string=?))
(define (priv:locale-abbr-month->index string)
(priv:vector-find string priv:locale-abbr-month-vector string=?))
(priv:date-reverse-lookup string priv:locale-abbr-month 12 string=?))
(define (priv:locale-long-month->index string)
(priv:vector-find string priv:locale-long-month-vector string=?))
(priv:date-reverse-lookup string priv:locale-long-month 12 string=?))
;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
@ -1003,10 +960,8 @@
(define (priv:locale-print-time-zone date port)
(priv:tz-printer (date-zone-offset date) port))
;; FIXME: we should use strftime to determine this dynamically if possible.
;; Again, locale specific.
(define (priv:locale-am/pm hr)
(if (> hr 11) priv:locale-pm priv:locale-am))
(if (> hr 11) (priv:locale-pm) (priv:locale-am)))
(define (priv:tz-printer offset port)
(cond
@ -1069,7 +1024,7 @@
(le (string-length ns)))
(if (> le 2)
(begin
(display priv:locale-number-separator port)
(display (priv:locale-number-separator) port)
(display (substring ns 2 le) port)))))))
(cons #\h (lambda (date pad-with port)
(display (date->string date "~b") port)))

2
srfi/srfi-60.c
View file

@ -86,7 +86,7 @@ SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0,
if (ii < SCM_LONG_BIT-1)
{
nn &= ~(1L << ii); /* zap bit at index */
nn |= (bb << ii); /* insert desired bit */
nn |= ((long) bb << ii); /* insert desired bit */
return scm_from_long (nn);
}
else

68
test-suite/ChangeLog
View file

@ -1,10 +1,72 @@
2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/i18n.test: Use `(srfi srfi-1)'.
(exception:locale-error): New.
(locale objects): Test `make-locale' with both lists of `LC_*'
values and single `LC_*' values (instead of `LC_*_MASK' values).
[%global-locale]: New test.
(number parsing)[locale-string->inexact (French)]: New test.
(%c-locale, %english-days, every?): New top-level variables.
(nl-langinfo et al.): New test prefix.
* tests/srfi-19.test: Install the C locale.
(SRFI date/time library)[string->date understands days and
months]: New test.
2007-01-19 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/eval.test (values): New test prefix. Values are structs,
and `equal?' on structs with `s' fields used to yield infinite
recursion.
* tests/structs.test (equal?): New test prefix. Added tests that
used to show the infinite recursion problem.
2007-01-16 Kevin Ryde <user42@zip.com.au>
* tests/regexp.test (regexp-exec): Further tests, in particular #\nul
in input and bad flags args which had been provoking abort()s.
* lib.scm (exception:string-contains-nul): New exception pattern.
2006-12-24 Han-Wen Nienhuys <hanwen@lilypond.org>
* tests/numbers.test ("equal?"): add case for reduction of
rational numbers.
2006-12-13 Kevin Ryde <user42@zip.com.au>
* tests/eval.test: Exercise top-level define setting procedure-name.
* tests/srfi-17.test (car): Check procedure-name property.
* tests/numbers.test (*): Exercise multiply by exact 0 giving exact 0.
2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/unif.test (syntax): New test prefix. Check syntax for
negative lower bounds and negative lengths (reported by Gyula
Szavai) as well as `array-in-bounds?'.
2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
2006-12-09 Kevin Ryde <user42@zip.com.au>
* standalone/test-use-srfi: New test.
* standalone/Makefile.am (TESTS): Add it.
2006-12-03 Kevin Ryde <user42@zip.com.au>
* standalone/Makefile.am (.x): Change from %.c %.x style to .c.x style
since the former is a GNU make extension. (Rule now as per
libguile/Makefile.am.)
* standalone/Makefile.am (test_cflags): Change from := to plain =, as
the former is not portable (according to automake).
2006-12-02 Kevin Ryde <user42@zip.com.au>
* tests/numbers.test (min, max): Correction to big/real and real/big
tests, `big*5' will round on a 64-bit system. And use `eqv?' to
ensure intended exact vs inexact is checked. Reported by Aaron
M. Ucko, Debian bug 396119.
2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
* test-suite/tests/vectors.test: Use `define-module'.
(vector->list): New test prefix. "Shared array" test contributed
@ -24,7 +86,7 @@
* tests/environments.test: Comment out all tests in this file.
2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
* tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a
typo: `thrown' instead of `throw'.

8
test-suite/lib.scm
View file

@ -1,5 +1,5 @@
;;;; test-suite/lib.scm --- generic support for testing
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@ -30,6 +30,7 @@
exception:numerical-overflow
exception:struct-set!-denied
exception:miscellaneous-error
exception:string-contains-nul
;; Reporting passes and failures.
run-test
@ -259,6 +260,11 @@
(define exception:miscellaneous-error
(cons 'misc-error "^.*"))
;; as per throw in scm_to_locale_stringn()
(define exception:string-contains-nul
(cons 'misc-error "^string contains #\\\\nul character"))
;;; Display all parameters to the default output port, followed by a newline.
(define (display-line . objs)
(for-each display objs)

8
test-suite/standalone/Makefile.am
View file

@ -29,7 +29,7 @@ BUILT_SOURCES =
TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env"
test_cflags := \
test_cflags = \
-I$(top_srcdir)/test-suite/standalone \
-I$(top_srcdir) \
-I$(top_srcdir)/libguile-ltdl $(EXTRA_DEFS) $(GUILE_CFLAGS)
@ -38,7 +38,8 @@ AM_LDFLAGS = $(GUILE_CFLAGS)
snarfcppopts = \
$(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) -I$(top_srcdir)
%.x: %.c
SUFFIXES = .x
.c.x:
${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts)
CLEANFILES = *.x
@ -102,6 +103,9 @@ test_conversion_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-conversion
TESTS += test-conversion
# test-use-srfi
TESTS += test-use-srfi
all-local:
cd ${srcdir} && chmod u+x ${check_SCRIPTS}

67
test-suite/standalone/test-use-srfi Executable file
View file

@ -0,0 +1,67 @@
#!/bin/sh
# 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
# Test that two srfi numbers on the command line work.
#
guile --use-srfi=1,10 >/dev/null <<EOF
(if (and (defined? 'partition)
(defined? 'define-reader-ctor))
(exit 0) ;; good
(exit 1)) ;; bad
EOF
if test $? = 0; then :; else
echo "guile --user-srfi=1,10 fails to run"
exit 1
fi
# Test that running "guile --use-srfi=1" leaves the interactive REPL with
# the srfi-1 version of iota.
#
# In guile 1.8.1 and earlier, and 1.6.8 and earlier, these failed because in
# `top-repl' the core bindings got ahead of anything --use-srfi gave.
#
guile --use-srfi=1 >/dev/null <<EOF
(catch #t
(lambda ()
(iota 2 3 4))
(lambda args
(exit 1))) ;; bad
(exit 0) ;; good
EOF
if test $? = 0; then :; else
echo "guile --user-srfi=1 doesn't give SRFI-1 iota"
exit 1
fi
# Similar test on srfi-17 car, which differs in being a #:replacement. This
# exercises duplicates handling in `top-repl' versus `use-srfis' (in
# boot-9.scm).
#
guile --use-srfi=17 >/dev/null <<EOF
(if (procedure-with-setter? car)
(exit 0) ;; good
(exit 1)) ;; bad
EOF
if test $? = 0; then :; else
echo "guile --user-srfi=17 doesn't give SRFI-17 car"
exit 1
fi

44
test-suite/tests/eval.test
View file

@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 2000, 2001, 2006, 2007 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
@ -201,6 +201,33 @@
(map + '(1 2) '(3)))
)))
;;;
;;; define with procedure-name
;;;
(define old-procnames-flag (memq 'procnames (debug-options)))
(debug-enable 'procnames)
;; names are only set on top-level procedures (currently), so these can't be
;; hidden in a let
;;
(define foo-closure (lambda () "hello"))
(define bar-closure foo-closure)
(define foo-pws (make-procedure-with-setter car set-car!))
(define bar-pws foo-pws)
(with-test-prefix "define set procedure-name"
(pass-if "closure"
(eq? 'foo-closure (procedure-name bar-closure)))
(pass-if "procedure-with-setter"
(eq? 'foo-pws (pk (procedure-name bar-pws)))))
(if old-procnames-flag
(debug-enable 'procnames)
(debug-disable 'procnames))
;;;
;;; promises
;;;
@ -288,5 +315,20 @@
'(a b c d e f g h i j k l m
n o p q r s t u v w x y z))))
;;;
;;; values
;;;
(with-test-prefix "values"
(pass-if "single value"
(equal? 1 (values 1)))
(pass-if "call-with-values"
(equal? (call-with-values (lambda () (values 1 2 3 4)) list)
'(1 2 3 4)))
(pass-if "equal?"
(equal? (values 1 2 3 4) (values 1 2 3 4))))
;;; eval.test ends here

141
test-suite/tests/i18n.test
View file

@ -1,6 +1,6 @@
;;;; i18n.test --- Exercise the i18n API.
;;;;
;;;; Copyright (C) 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -19,25 +19,41 @@
(define-module (test-suite i18n)
:use-module (ice-9 i18n)
:use-module (srfi srfi-1)
:use-module (test-suite lib))
;; Start from a pristine locale state.
(setlocale LC_ALL "C")
(define exception:locale-error
(cons 'system-error "Failed to install locale"))
(with-test-prefix "locale objects"
(pass-if "make-locale (2 args)"
(not (not (make-locale LC_ALL_MASK "C"))))
(not (not (make-locale LC_ALL "C"))))
(pass-if "make-locale (2 args, list)"
(not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C"))))
(pass-if "make-locale (3 args)"
(not (not (make-locale LC_COLLATE_MASK "C"
(make-locale LC_MESSAGES_MASK "C")))))
(not (not (make-locale (list LC_COLLATE) "C"
(make-locale (list LC_MESSAGES) "C")))))
(pass-if-exception "make-locale with unknown locale" exception:locale-error
(make-locale LC_ALL "does-not-exist"))
(pass-if "locale?"
(and (locale? (make-locale LC_ALL_MASK "C"))
(locale? (make-locale (logior LC_MESSAGES_MASK LC_NUMERIC_MASK) "C"
(make-locale LC_CTYPE_MASK "C"))))))
(and (locale? (make-locale (list LC_ALL) "C"))
(locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C"
(make-locale (list LC_CTYPE) "C")))))
(pass-if "%global-locale"
(and (locale? %global-locale))
(locale? (make-locale (list LC_MONETARY) "C"
%global-locale))))
@ -46,27 +62,30 @@
(pass-if "string-locale<?"
(and (string-locale<? "hello" "world")
(string-locale<? "hello" "world"
(make-locale LC_COLLATE_MASK "C"))))
(make-locale (list LC_COLLATE) "C"))))
(pass-if "char-locale<?"
(and (char-locale<? #\a #\b)
(char-locale<? #\a #\b (make-locale LC_COLLATE_MASK "C"))))
(char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C"))))
(pass-if "string-locale-ci=?"
(and (string-locale-ci=? "Hello" "HELLO")
(string-locale-ci=? "Hello" "HELLO"
(make-locale LC_COLLATE_MASK "C"))))
(make-locale (list LC_COLLATE) "C"))))
(pass-if "string-locale-ci<?"
(and (string-locale-ci<? "hello" "WORLD")
(string-locale-ci<? "hello" "WORLD"
(make-locale LC_COLLATE_MASK "C")))))
(make-locale (list LC_COLLATE) "C")))))
(define %french-locale-name
"fr_FR.ISO-8859-1")
(define %french-locale
(false-if-exception
(make-locale (logior LC_CTYPE_MASK LC_COLLATE_MASK)
"fr_FR.ISO-8859-1")))
(make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
%french-locale-name)))
(define (under-french-locale-or-unresolved thunk)
;; On non-GNU systems, an exception may be raised only when the locale is
@ -112,11 +131,11 @@
(pass-if "char-locale-downcase"
(and (eq? #\a (char-locale-downcase #\A))
(eq? #\a (char-locale-downcase #\A (make-locale LC_ALL_MASK "C")))))
(eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
(pass-if "char-locale-upcase"
(and (eq? #\Z (char-locale-upcase #\z))
(eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL_MASK "C"))))))
(eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C"))))))
(with-test-prefix "number parsing"
@ -131,10 +150,98 @@
(call-with-values
(lambda ()
(locale-string->inexact "123.456"
(make-locale LC_NUMERIC_MASK "C")))
(make-locale (list LC_NUMERIC) "C")))
(lambda (result char-count)
(and (equal? result 123.456)
(equal? char-count 7))))))
(equal? char-count 7)))))
(pass-if "locale-string->inexact (French)"
(under-french-locale-or-unresolved
(lambda ()
(call-with-values
(lambda ()
(locale-string->inexact "123,456" %french-locale))
(lambda (result char-count)
(and (equal? result 123.456)
(equal? char-count 7))))))))
;;;
;;; `nl-langinfo'
;;;
(setlocale LC_ALL "C")
(define %c-locale (make-locale LC_ALL "C"))
(define %english-days
'("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
(define (every? . args)
(not (not (apply every args))))
(with-test-prefix "nl-langinfo et al."
(pass-if "locale-day (1 arg)"
(every? equal?
%english-days
(map locale-day (map 1+ (iota 7)))))
(pass-if "locale-day (2 args)"
(every? equal?
%english-days
(map (lambda (day)
(locale-day day %c-locale))
(map 1+ (iota 7)))))
(pass-if "locale-day (2 args, using `%global-locale')"
(every? equal?
%english-days
(map (lambda (day)
(locale-day day %global-locale))
(map 1+ (iota 7)))))
(pass-if "locale-day (French)"
(under-french-locale-or-unresolved
(lambda ()
(let ((result (locale-day 3 %french-locale)))
(and (string? result)
(string-ci=? result "mardi"))))))
(pass-if "locale-day (French, using `%global-locale')"
;; Make sure `%global-locale' captures the current locale settings as
;; installed using `setlocale'.
(under-french-locale-or-unresolved
(lambda ()
(dynamic-wind
(lambda ()
(setlocale LC_TIME %french-locale-name))
(lambda ()
(let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
(result (locale-day 3 fr)))
(setlocale LC_ALL "C")
(and (string? result)
(string-ci=? result "mardi"))))
(lambda ()
(setlocale LC_ALL "C"))))))
(pass-if "default locale"
;; Make sure the default locale does not capture the current locale
;; settings as installed using `setlocale'. The default locale should be
;; "C".
(under-french-locale-or-unresolved
(lambda ()
(dynamic-wind
(lambda ()
(setlocale LC_ALL %french-locale-name))
(lambda ()
(let* ((locale (make-locale (list LC_MONETARY) "C"))
(result (locale-day 3 locale)))
(setlocale LC_ALL "C")
(and (string? result)
(string-ci=? result "Tuesday"))))
(lambda ()
(setlocale LC_ALL "C")))))))
;;; Local Variables:

92
test-suite/tests/numbers.test
View file

@ -2243,19 +2243,17 @@
(with-test-prefix "big / real"
(pass-if (nan? (max big*5 +nan.0)))
(pass-if (= big*5 (max big*5 -inf.0)))
(pass-if (= +inf.0 (max big*5 +inf.0)))
(pass-if (= 1.0 (max (- big*5) 1.0)))
(pass-if (inexact? (max big*5 1.0)))
(pass-if (= (exact->inexact big*5) (max big*5 1.0))))
(pass-if (eqv? (exact->inexact big*5) (max big*5 -inf.0)))
(pass-if (eqv? (exact->inexact big*5) (max big*5 1.0)))
(pass-if (eqv? +inf.0 (max big*5 +inf.0)))
(pass-if (eqv? 1.0 (max (- big*5) 1.0))))
(with-test-prefix "real / big"
(pass-if (nan? (max +nan.0 big*5)))
(pass-if (= +inf.0 (max +inf.0 big*5)))
(pass-if (= big*5 (max -inf.0 big*5)))
(pass-if (= 1.0 (max 1.0 (- big*5))))
(pass-if (inexact? (max 1.0 big*5)))
(pass-if (= (exact->inexact big*5) (max 1.0 big*5))))
(pass-if (eqv? (exact->inexact big*5) (max -inf.0 big*5)))
(pass-if (eqv? (exact->inexact big*5) (max 1.0 big*5)))
(pass-if (eqv? +inf.0 (max +inf.0 big*5)))
(pass-if (eqv? 1.0 (max 1.0 (- big*5)))))
(with-test-prefix "frac / frac"
(pass-if (= 2/3 (max 1/2 2/3)))
@ -2370,19 +2368,17 @@
(with-test-prefix "big / real"
(pass-if (nan? (min big*5 +nan.0)))
(pass-if (= big*5 (min big*5 +inf.0)))
(pass-if (= -inf.0 (min big*5 -inf.0)))
(pass-if (= 1.0 (min big*5 1.0)))
(pass-if (inexact? (min (- big*5) 1.0)))
(pass-if (= (exact->inexact (- big*5)) (min (- big*5) 1.0))))
(pass-if (eqv? (exact->inexact big*5) (min big*5 +inf.0)))
(pass-if (eqv? -inf.0 (min big*5 -inf.0)))
(pass-if (eqv? 1.0 (min big*5 1.0)))
(pass-if (eqv? (exact->inexact (- big*5)) (min (- big*5) 1.0))))
(with-test-prefix "real / big"
(pass-if (nan? (min +nan.0 big*5)))
(pass-if (= big*5 (min +inf.0 big*5)))
(pass-if (= -inf.0 (min -inf.0 big*5)))
(pass-if (= 1.0 (min 1.0 big*5)))
(pass-if (inexact? (min 1.0 (- big*5))))
(pass-if (= (exact->inexact (- big*5)) (min 1.0 (- big*5)))))
(pass-if (eqv? (exact->inexact big*5) (min +inf.0 big*5)))
(pass-if (eqv? -inf.0 (min -inf.0 big*5)))
(pass-if (eqv? 1.0 (min 1.0 big*5)))
(pass-if (eqv? (exact->inexact (- big*5)) (min 1.0 (- big*5)))))
(with-test-prefix "frac / frac"
(pass-if (= 1/2 (min 1/2 2/3)))
@ -2463,10 +2459,52 @@
(with-test-prefix "*"
(with-test-prefix "inum * bignum"
(pass-if "0 * 2^256 = 0"
(eqv? 0 (* 0 (ash 1 256)))))
(with-test-prefix "inum * flonum"
(pass-if "0 * 1.0 = 0"
(eqv? 0 (* 0 1.0))))
(with-test-prefix "inum * complex"
(pass-if "0 * 1+1i = 0"
(eqv? 0 (* 0 1+1i))))
(with-test-prefix "inum * frac"
(pass-if "0 * 2/3 = 0"
(eqv? 0 (* 0 2/3))))
(with-test-prefix "bignum * inum"
(pass-if "2^256 * 0 = 0"
(eqv? 0 (* (ash 1 256) 0))))
(with-test-prefix "flonum * inum"
;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0
(pass-if "1.0 * 0 = 0"
(eqv? 0 (* 1.0 0))))
(with-test-prefix "complex * inum"
;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0
(pass-if "1+1i * 0 = 0"
(eqv? 0 (* 1+1i 0))))
(pass-if "complex * bignum"
(let ((big (ash 1 90)))
(= (make-rectangular big big)
(* 1+1i big)))))
(* 1+1i big))))
(with-test-prefix "frac * inum"
(pass-if "2/3 * 0 = 0"
(eqv? 0 (* 2/3 0)))))
;;;
;;; /
@ -3180,3 +3218,15 @@
(pass-if "-100i swings back to 45deg down"
(eqv-loosely? +7.071-7.071i (sqrt -100.0i))))
;;
;; equal?
;;
(with-test-prefix "equal?"
(pass-if
;; lazy reduction bit for rationals should not affect equal?
(equal? 1/2 ((lambda (x) (denominator x) x) 1/2))))

34
test-suite/tests/regexp.test
View file

@ -1,7 +1,7 @@
;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;;
;;;; Copyright (C) 1999, 2004, 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2004, 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@ -70,6 +70,38 @@
(pass-if "foo offset 1"
(string=? "foo" (match:string (string-match ".*" "foo" 1)))))
;;;
;;; regexp-exec
;;;
(with-test-prefix "regexp-exec"
(pass-if-exception "non-integer offset" exception:wrong-type-arg
(let ((re (make-regexp "ab+")))
(regexp-exec re "aaaabbbb" 1.5 'bogus-flags-arg)))
(pass-if-exception "non-string input" exception:wrong-type-arg
(let ((re (make-regexp "ab+")))
(regexp-exec re 'not-a-string)))
(pass-if-exception "non-string input, with offset" exception:wrong-type-arg
(let ((re (make-regexp "ab+")))
(regexp-exec re 'not-a-string 5)))
;; in guile 1.8.1 and earlier, a #\nul character in the input string was
;; only detected in a critical section, and the resulting error throw
;; abort()ed the program
(pass-if-exception "nul in input" exception:string-contains-nul
(let ((re (make-regexp "ab+")))
(regexp-exec re (string #\a #\b (integer->char 0)))))
;; in guile 1.8.1 and earlier, a bogus flags argument was only detected
;; inside a critical section, and the resulting error throw abort()ed the
;; program
(pass-if-exception "non-integer flags" exception:wrong-type-arg
(let ((re (make-regexp "ab+")))
(regexp-exec re "aaaabbbb" 0 'bogus-flags-arg))))
;;;
;;; regexp-quote
;;;

7
test-suite/tests/srfi-17.test
View file

@ -32,6 +32,13 @@
(with-test-prefix "car"
;; this test failed in guile 1.8.1 and 1.6.8 and earlier, since `define'
;; didn't set a name on a procedure-with-setter
(pass-if "procedure-name"
(if (memq 'procnames (debug-options)) ;; enabled by default
(eq? 'car (procedure-name car))
(throw 'unsupported)))
(pass-if "set! (car x)"
(let ((lst (list 1)))
(set! (car lst) 2)

16
test-suite/tests/srfi-19.test
View file

@ -27,6 +27,9 @@
:use-module (srfi srfi-19)
:use-module (ice-9 format))
;; Make sure we use the default locale.
(setlocale LC_ALL "C")
(define (with-tz* tz thunk)
"Temporarily set the TZ environment variable to the passed string
value and call THUNK."
@ -142,6 +145,19 @@ incomplete numerical tower implementation.)"
(string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
(date->time-utc
(make-date 0 0 0 12 1 6 2001 0))))
(pass-if "string->date understands days and months"
(time=? (let ((d (string->date "Saturday, December 9, 2006"
"~A, ~B ~d, ~Y")))
(date->time-utc (make-date (date-nanosecond d)
(date-second d)
(date-minute d)
(date-hour d)
(date-day d)
(date-month d)
(date-year d)
0)))
(date->time-utc
(make-date 0 0 0 0 9 12 2006 0))))
;; check time comparison procedures
(let* ((time1 (make-time time-monotonic 0 0))
(time2 (make-time time-monotonic 0 0))

25
test-suite/tests/structs.test
View file

@ -1,7 +1,7 @@
;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*-
;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
;;;;
;;;; Copyright (C) 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@ -18,7 +18,8 @@
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
(use-modules (test-suite lib))
(define-module (test-suite test-structs)
:use-module (test-suite lib))
@ -80,15 +81,27 @@
(pass-if "struct-set!"
(let ((ball (make-ball green "Bob")))
(set-owner! ball "Bill")
(string=? (owner ball) "Bill")))
(string=? (owner ball) "Bill"))))
(pass-if "equal?"
(with-test-prefix "equal?"
(pass-if "simple structs"
(let* ((vtable (make-vtable-vtable "pr" 0))
(s1 (make-struct vtable 0 "hello"))
(s2 (make-struct vtable 0 "hello")))
(equal? s1 s2)))
(pass-if "more complex structs"
(let ((first (make-ball red (string-copy "Bob")))
(second (make-ball red (string-copy "Bob"))))
(second (make-ball red (string-copy "Bob"))))
(equal? first second)))
(pass-if "not-equal?"
(not (or (equal? (make-ball red "Bob") (make-ball green "Bill"))
(not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
(equal? (make-ball red "Bob") (make-ball red "Bill"))))))
;;; Local Variables:
;;; coding: latin-1
;;; End: