mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Merge commit 'origin/master' into vm
Conflicts: .gitignore guile-tools.in srfi/srfi-19.scm
This commit is contained in:
Andy Wingo
commit
c32929d14d
89 changed files with 2412 additions and 4369 deletions
6
.gitignore
vendored
6
.gitignore
vendored
|
|
@ -71,6 +71,8 @@ guile-readline/guile-readline-config.h.in
|
|||
*.go
|
||||
TAGS
|
||||
guile-1.8.pc
|
||||
lib/alloca.h
|
||||
lib/strings.h
|
||||
gdb-pre-inst-guile
|
||||
libguile/stack-limit-calibration.scm
|
||||
cscope.out
|
||||
cscope.files
|
||||
*.log
|
||||
|
|
|
|||
4
AUTHORS
4
AUTHORS
|
|
@ -339,3 +339,7 @@ In the subdirectory libguile, changes to:
|
|||
|
||||
John W. Eaton, based on code from AT&T Bell Laboratories and Bellcore:
|
||||
The complex number division method in libguile/numbers.c.
|
||||
|
||||
Gregory Marton:
|
||||
In the subdirectory test-suite/tests, changes to:
|
||||
hash.test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
-*- text -*-
|
||||
|
||||
Starting from September 1st, 2008, the Guile projects no longer stores
|
||||
Starting from September 1st, 2008, the Guile project no longer stores
|
||||
change logs in `ChangeLog' files. Instead, changes are detailed in the
|
||||
version control system's logs. They can be seen by downloading a copy
|
||||
of the Git repository:
|
||||
|
|
|
|||
94
INSTALL
94
INSTALL
|
|
@ -2,15 +2,15 @@ Installation Instructions
|
|||
*************************
|
||||
|
||||
Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005,
|
||||
2006, 2007 Free Software Foundation, Inc.
|
||||
2006, 2007, 2008 Free Software Foundation, Inc.
|
||||
|
||||
This file is free documentation; the Free Software Foundation gives
|
||||
This file is free documentation; the Free Software Foundation gives
|
||||
unlimited permission to copy, distribute and modify it.
|
||||
|
||||
Basic Installation
|
||||
==================
|
||||
|
||||
Briefly, the shell commands `./configure; make; make install' should
|
||||
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.
|
||||
|
|
@ -73,9 +73,9 @@ The simplest way to compile this package is:
|
|||
Compilers and Options
|
||||
=====================
|
||||
|
||||
Some systems require unusual options for compilation or linking that the
|
||||
`configure' script does not know about. Run `./configure --help' for
|
||||
details on some of the pertinent environment variables.
|
||||
Some systems require unusual options for compilation or linking that
|
||||
the `configure' script does not know about. Run `./configure --help'
|
||||
for details on some of the pertinent environment variables.
|
||||
|
||||
You can give `configure' initial values for configuration parameters
|
||||
by setting variables in the command line or in the environment. Here
|
||||
|
|
@ -88,7 +88,7 @@ is an example:
|
|||
Compiling For Multiple Architectures
|
||||
====================================
|
||||
|
||||
You can compile the package for more than one kind of computer at the
|
||||
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 can use GNU `make'. `cd' to the
|
||||
directory where you want the object files and executables to go and run
|
||||
|
|
@ -100,10 +100,24 @@ 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.
|
||||
|
||||
On MacOS X 10.5 and later systems, you can create libraries and
|
||||
executables that work on multiple system types--known as "fat" or
|
||||
"universal" binaries--by specifying multiple `-arch' options to the
|
||||
compiler but only a single `-arch' option to the preprocessor. Like
|
||||
this:
|
||||
|
||||
./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
|
||||
CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
|
||||
CPP="gcc -E" CXXCPP="g++ -E"
|
||||
|
||||
This is not guaranteed to produce working output in all cases, you
|
||||
may have to build one architecture at a time and combine the results
|
||||
using the `lipo' tool if you have problems.
|
||||
|
||||
Installation Names
|
||||
==================
|
||||
|
||||
By default, `make install' installs the package's commands under
|
||||
By default, `make install' installs the package's commands under
|
||||
`/usr/local/bin', include files under `/usr/local/include', etc. You
|
||||
can specify an installation prefix other than `/usr/local' by giving
|
||||
`configure' the option `--prefix=PREFIX'.
|
||||
|
|
@ -126,7 +140,7 @@ option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
|
|||
Optional Features
|
||||
=================
|
||||
|
||||
Some packages pay attention to `--enable-FEATURE' options to
|
||||
Some packages pay attention to `--enable-FEATURE' options to
|
||||
`configure', where FEATURE indicates an optional part of the package.
|
||||
They may also pay attention to `--with-PACKAGE' options, where PACKAGE
|
||||
is something like `gnu-as' or `x' (for the X Window System). The
|
||||
|
|
@ -138,14 +152,36 @@ find the X include and library files automatically, but if it doesn't,
|
|||
you can use the `configure' options `--x-includes=DIR' and
|
||||
`--x-libraries=DIR' to specify their locations.
|
||||
|
||||
Particular systems
|
||||
==================
|
||||
|
||||
On HP-UX, the default C compiler is not ANSI C compatible. If GNU
|
||||
CC is not installed, it is recommended to use the following options in
|
||||
order to use an ANSI C compiler:
|
||||
|
||||
./configure CC="cc -Ae"
|
||||
|
||||
and if that doesn't work, install pre-built binaries of GCC for HP-UX.
|
||||
|
||||
On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot
|
||||
parse its `<wchar.h>' header file. The option `-nodtk' can be used as
|
||||
a workaround. If GNU CC is not installed, it is therefore recommended
|
||||
to try
|
||||
|
||||
./configure CC="cc"
|
||||
|
||||
and if that doesn't work, try
|
||||
|
||||
./configure CC="cc -nodtk"
|
||||
|
||||
Specifying the System Type
|
||||
==========================
|
||||
|
||||
There may be some features `configure' cannot figure out automatically,
|
||||
but needs to determine by the type of machine the package will run on.
|
||||
Usually, assuming the package is built to be run on the _same_
|
||||
architectures, `configure' can figure that out, but if it prints a
|
||||
message saying it cannot guess the machine type, give it the
|
||||
There may be some features `configure' cannot figure out
|
||||
automatically, but needs to determine by the type of machine the package
|
||||
will run on. Usually, assuming the package is built to be run on the
|
||||
_same_ architectures, `configure' can figure that out, but if it prints
|
||||
a message saying it cannot guess the machine type, give it the
|
||||
`--build=TYPE' option. TYPE can either be a short name for the system
|
||||
type, such as `sun4', or a canonical name which has the form:
|
||||
|
||||
|
|
@ -171,9 +207,9 @@ eventually be run) with `--host=TYPE'.
|
|||
Sharing Defaults
|
||||
================
|
||||
|
||||
If you want to set default values for `configure' scripts to share, you
|
||||
can create a site shell script called `config.site' that gives default
|
||||
values for variables like `CC', `cache_file', and `prefix'.
|
||||
If you want to set default values for `configure' scripts to share,
|
||||
you can create a site shell script called `config.site' that gives
|
||||
default values for variables like `CC', `cache_file', and `prefix'.
|
||||
`configure' looks for `PREFIX/share/config.site' if it exists, then
|
||||
`PREFIX/etc/config.site' if it exists. Or, you can set the
|
||||
`CONFIG_SITE' environment variable to the location of the site script.
|
||||
|
|
@ -182,7 +218,7 @@ A warning: not all `configure' scripts look for a site script.
|
|||
Defining Variables
|
||||
==================
|
||||
|
||||
Variables not defined in a site shell script can be set in the
|
||||
Variables not defined in a site shell script can be set in the
|
||||
environment passed to `configure'. However, some packages may run
|
||||
configure again during the build, and the customized values of these
|
||||
variables may be lost. In order to avoid this problem, you should set
|
||||
|
|
@ -201,11 +237,19 @@ an Autoconf bug. Until the bug is fixed you can use this workaround:
|
|||
`configure' Invocation
|
||||
======================
|
||||
|
||||
`configure' recognizes the following options to control how it operates.
|
||||
`configure' recognizes the following options to control how it
|
||||
operates.
|
||||
|
||||
`--help'
|
||||
`-h'
|
||||
Print a summary of the options to `configure', and exit.
|
||||
Print a summary of all of the options to `configure', and exit.
|
||||
|
||||
`--help=short'
|
||||
`--help=recursive'
|
||||
Print a summary of the options unique to this package's
|
||||
`configure', and exit. The `short' variant lists options used
|
||||
only in the top level, while the `recursive' variant lists options
|
||||
also present in any nested packages.
|
||||
|
||||
`--version'
|
||||
`-V'
|
||||
|
|
@ -232,6 +276,16 @@ an Autoconf bug. Until the bug is fixed you can use this workaround:
|
|||
Look for the package's source code in directory DIR. Usually
|
||||
`configure' can determine that directory automatically.
|
||||
|
||||
`--prefix=DIR'
|
||||
Use DIR as the installation prefix. *Note Installation Names::
|
||||
for more details, including other options available for fine-tuning
|
||||
the installation locations.
|
||||
|
||||
`--no-create'
|
||||
`-n'
|
||||
Run the configure checks, but stop before creating any output
|
||||
files.
|
||||
|
||||
`configure' also accepts some other, not widely useful, options. Run
|
||||
`configure --help' for more details.
|
||||
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ EXTRA_DIST = LICENSE HACKING GUILE-VERSION \
|
|||
|
||||
TESTS = check-guile
|
||||
|
||||
ACLOCAL_AMFLAGS = -I guile-config -I m4
|
||||
ACLOCAL_AMFLAGS = -I m4
|
||||
|
||||
DISTCLEANFILES = check-guile.log
|
||||
|
||||
|
|
|
|||
41
NEWS
41
NEWS
|
|
@ -2,9 +2,7 @@ Guile NEWS --- history of user-visible changes.
|
|||
Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
|
||||
See the end for copying conditions.
|
||||
|
||||
Please send Guile bug reports to bug-guile@gnu.org. Note that you
|
||||
must be subscribed to this list first, in order to successfully send a
|
||||
report to it.
|
||||
Please send Guile bug reports to bug-guile@gnu.org.
|
||||
|
||||
|
||||
Changes in 1.9.0:
|
||||
|
|
@ -42,6 +40,12 @@ application code.
|
|||
** Functions for handling `scm_option' now no longer require an argument
|
||||
indicating length of the `scm_t_option' array.
|
||||
|
||||
|
||||
Changes in 1.8.7 (since 1.8.6)
|
||||
|
||||
* Bugs fixed
|
||||
|
||||
** Fix %fast-slot-ref/set!, to avoid possible segmentation fault
|
||||
|
||||
|
||||
Changes in 1.8.6 (since 1.8.5)
|
||||
|
|
@ -56,6 +60,8 @@ When you use GDS to evaluate Scheme code from Emacs, you can now use
|
|||
`C-u' to indicate that you want to single step through that code. See
|
||||
`Evaluating Scheme Code' in the manual for more details.
|
||||
|
||||
** New "guile(1)" man page!
|
||||
|
||||
* Changes to the distribution
|
||||
|
||||
** Automake's `AM_MAINTAINER_MODE' is no longer used
|
||||
|
|
@ -63,10 +69,15 @@ When you use GDS to evaluate Scheme code from Emacs, you can now use
|
|||
Thus, the `--enable-maintainer-mode' configure option is no longer
|
||||
available: Guile is now always configured in "maintainer mode".
|
||||
|
||||
** `ChangeLog' files are no longer updated
|
||||
|
||||
Instead, changes are detailed in the version control system's logs. See
|
||||
the top-level `ChangeLog' files for details.
|
||||
|
||||
|
||||
* Bugs fixed
|
||||
|
||||
** `symbol->string' now returns a read-only string, as per R5RS
|
||||
** Literal strings as returned by `read' are now read-only, as per R5RS
|
||||
** Fix incorrect handling of the FLAGS argument of `fold-matches'
|
||||
** `guile-config link' now prints `-L$libdir' before `-lguile'
|
||||
** Fix memory corruption involving GOOPS' `class-redefinition'
|
||||
|
|
@ -74,9 +85,18 @@ available: Guile is now always configured in "maintainer mode".
|
|||
** Fix build issue on Tru64 and ia64-hp-hpux11.23 (`SCM_UNPACK' macro)
|
||||
** Fix build issue on mips, mipsel, powerpc and ia64 (stack direction)
|
||||
** Fix build issue on hppa2.0w-hp-hpux11.11 (`dirent64' and `readdir64_r')
|
||||
** Fix build issue on i386-unknown-freebsd7.0 ("break strict-aliasing rules")
|
||||
** Fix misleading output from `(help rationalize)'
|
||||
** Fix build failure on Debian hppa architecture (bad stack growth detection)
|
||||
** Fix `gcd' when called with a single, negative argument.
|
||||
** Fix `Stack overflow' errors seen when building on some platforms
|
||||
** Fix bug when `scm_with_guile ()' was called several times from the
|
||||
same thread
|
||||
** The handler of SRFI-34 `with-exception-handler' is now invoked in the
|
||||
dynamic environment of the call to `raise'
|
||||
** Fix potential deadlock in `make-struct'
|
||||
** Fix compilation problem with libltdl from Libtool 2.2.x
|
||||
** Fix sloppy bound checking in `string-{ref,set!}' with the empty string
|
||||
|
||||
|
||||
Changes in 1.8.5 (since 1.8.4)
|
||||
|
|
@ -229,7 +249,6 @@ Changes in 1.8.3 (since 1.8.2)
|
|||
** The reader is now faster, which reduces startup time
|
||||
** Procedures returned by `record-accessor' and `record-modifier' are faster
|
||||
|
||||
|
||||
|
||||
Changes in 1.8.2 (since 1.8.1):
|
||||
|
||||
|
|
@ -238,6 +257,16 @@ Changes in 1.8.2 (since 1.8.1):
|
|||
** set-program-arguments
|
||||
** make-vtable
|
||||
|
||||
* Incompatible changes
|
||||
|
||||
** The body of a top-level `define' no longer sees the binding being created
|
||||
|
||||
In a top-level `define', the binding being created is no longer visible
|
||||
from the `define' body. This breaks code like
|
||||
"(define foo (begin (set! foo 1) (+ foo 1)))", where `foo' is now
|
||||
unbound in the body. However, such code was not R5RS-compliant anyway,
|
||||
per Section 5.2.1.
|
||||
|
||||
* Bugs fixed
|
||||
|
||||
** Fractions were not `equal?' if stored in unreduced form.
|
||||
|
|
@ -282,8 +311,6 @@ Changes in 1.8.1 (since 1.8.0):
|
|||
** scm_exp - [C]
|
||||
** scm_sqrt - [C]
|
||||
|
||||
* New `(ice-9 i18n)' module (see the manual for details)
|
||||
|
||||
* Bugs fixed
|
||||
|
||||
** Build problems have been fixed on MacOS, SunOS, and QNX.
|
||||
|
|
|
|||
4
README
4
README
|
|
@ -16,9 +16,7 @@ This has been the case since the 1.3.* series.
|
|||
|
||||
The next stable release will likely be version 1.10.0.
|
||||
|
||||
Please send bug reports to bug-guile@gnu.org. Note that you must be
|
||||
subscribed to this list first, in order to successfully send a report
|
||||
to it.
|
||||
Please send bug reports to bug-guile@gnu.org.
|
||||
|
||||
See the LICENSE file for the specific terms that apply to Guile.
|
||||
|
||||
|
|
|
|||
2
THANKS
2
THANKS
|
|
@ -5,6 +5,7 @@ Contributors since the last release:
|
|||
Julian Graham
|
||||
Stefan Jahn
|
||||
Neil Jerram
|
||||
Gregory Marton
|
||||
Antoine Mathys
|
||||
Thien-Thi Nguyen
|
||||
Han-Wen Nienhuys
|
||||
|
|
@ -94,6 +95,7 @@ For fixes or providing information which led to a fix:
|
|||
Aaron M. Ucko
|
||||
Stephen Uitti
|
||||
Momchil Velikov
|
||||
Linas Vepstas
|
||||
Panagiotis Vossos
|
||||
Neil W. Van Dyke
|
||||
Aaron VanDevender
|
||||
|
|
|
|||
|
|
@ -25,13 +25,4 @@ echo ""
|
|||
|
||||
autoreconf -i --force --verbose
|
||||
|
||||
echo "guile-readline..."
|
||||
(cd guile-readline && ./autogen.sh)
|
||||
|
||||
# Copy versions of config.guess and config.sub from Guile's repository to
|
||||
# build-aux and guile-readline.
|
||||
cp -f config.guess config.sub build-aux/
|
||||
cp -f config.guess config.sub guile-readline/
|
||||
|
||||
echo "Now run configure and make."
|
||||
echo "You must pass the \`--enable-maintainer-mode' option to configure."
|
||||
|
|
|
|||
|
|
@ -12,9 +12,7 @@ You can reference the file `lib.scm' from your own code as the module
|
|||
(benchmark-suite lib); it also has comments at the top and before each
|
||||
function explaining what's going on.
|
||||
|
||||
Please write more Guile benchmarks, and send them to
|
||||
bug-guile@gnu.org. (Note that you must be subscribed to this list
|
||||
first, in order to successfully send a message to it.) We'll merge
|
||||
them into the distribution. All benchmark suites must be licensed for
|
||||
our use under the GPL, but I don't think we're going to collect
|
||||
assignment papers for them.
|
||||
Please write more Guile benchmarks, and send them to bug-guile@gnu.org.
|
||||
We'll merge them into the distribution. All benchmark suites must be
|
||||
licensed for our use under the GPL, but I don't think we're going to
|
||||
collect assignment papers for them.
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then
|
|||
fi
|
||||
|
||||
exec $guile \
|
||||
-l ${top_builddir}/libguile/stack-limit-calibration.scm \
|
||||
-e main -s "$TEST_SUITE_DIR/guile-test" \
|
||||
--test-suite "$TEST_SUITE_DIR/tests" \
|
||||
--log-file check-guile.log "$@"
|
||||
|
|
|
|||
1526
config.guess
vendored
1526
config.guess
vendored
File diff suppressed because it is too large
Load diff
1654
config.sub
vendored
1654
config.sub
vendored
File diff suppressed because it is too large
Load diff
|
|
@ -86,8 +86,8 @@ AC_LIBTOOL_DLOPEN
|
|||
AC_PROG_LIBTOOL
|
||||
AC_CHECK_LIB([ltdl], [lt_dlinit], ,
|
||||
[AC_MSG_ERROR([libltdl not found. See README.])])
|
||||
|
||||
AC_SUBST(DLPREOPEN)
|
||||
AC_CHECK_HEADER([ltdl.h], [],
|
||||
[AC_MSG_ERROR([<ltdl.h> not found. See README.])])
|
||||
|
||||
AC_CHECK_PROG(have_makeinfo, makeinfo, yes, no)
|
||||
AM_CONDITIONAL(HAVE_MAKEINFO, test "$have_makeinfo" = yes)
|
||||
|
|
@ -1584,6 +1584,10 @@ AC_CONFIG_FILES([libguile/guile-func-name-check],
|
|||
[chmod +x libguile/guile-func-name-check])
|
||||
AC_CONFIG_FILES([libguile/guile-snarf-docs],
|
||||
[chmod +x libguile/guile-snarf-docs])
|
||||
AC_CONFIG_FILES([test-suite/standalone/test-use-srfi],
|
||||
[chmod +x test-suite/standalone/test-use-srfi])
|
||||
AC_CONFIG_FILES([test-suite/standalone/test-fast-slot-ref],
|
||||
[chmod +x test-suite/standalone/test-fast-slot-ref])
|
||||
|
||||
AC_OUTPUT
|
||||
|
||||
|
|
|
|||
|
|
@ -23,8 +23,7 @@ AUTOMAKE_OPTIONS = gnu
|
|||
|
||||
SUBDIRS = ref tutorial goops r5rs
|
||||
|
||||
# pending the papers from Robert Merkel
|
||||
# man_MANS = guile.1
|
||||
dist_man1_MANS = guile.1
|
||||
|
||||
EXAMPLE_SMOB_FILES = \
|
||||
ChangeLog-2008 Makefile README image-type.c image-type.h myguile.c
|
||||
|
|
@ -40,9 +39,6 @@ dist-hook:
|
|||
|
||||
EXTRA_DIST = groupings.alist ChangeLog-2008 # guile-api.alist
|
||||
|
||||
# pending the papers from Robert Merkel
|
||||
# EXTRA_DIST = guile.1
|
||||
|
||||
include $(top_srcdir)/am/maintainer-dirs
|
||||
guile-api.alist: guile-api.alist-FORCE
|
||||
( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist )
|
||||
|
|
|
|||
|
|
@ -26,6 +26,4 @@ info_TEXINFOS = goops.texi
|
|||
goops_TEXINFOS = goops-tutorial.texi \
|
||||
hierarchy.eps hierarchy.png hierarchy.txt hierarchy.pdf
|
||||
|
||||
TEXINFO_TEX = ../ref/texinfo.tex
|
||||
|
||||
EXTRA_DIST = ChangeLog-2008
|
||||
|
|
|
|||
14
doc/guile.1
14
doc/guile.1
|
|
@ -3,7 +3,7 @@
|
|||
.\" Process this file with
|
||||
.\" groff -man -Tascii foo.1
|
||||
.\"
|
||||
.TH GUILE 1 "January 2001" Version "1.4"
|
||||
.TH GUILE 1
|
||||
.SH NAME
|
||||
guile \- a Scheme interpreter
|
||||
.SH SYNOPSIS
|
||||
|
|
@ -11,8 +11,8 @@ guile \- a Scheme interpreter
|
|||
.B [-l FILE] [-e FUNCTION] [\]
|
||||
.B [-c EXPR] [-s SCRIPT] [--]
|
||||
.SH DESCRIPTION
|
||||
Guile is an interpreter for the Scheme programming language. It
|
||||
implements a superset of R4RS, providing the additional features
|
||||
GNU Guile is an interpreter for the Scheme programming language. It
|
||||
implements R5RS, providing additional features
|
||||
necessary for real-world use. It is extremely simple to embed guile
|
||||
into a C program, calling C from Scheme and Scheme from C. Guile's
|
||||
design makes it very suitable for use as an "extension" or "glue"
|
||||
|
|
@ -79,7 +79,13 @@ interface:
|
|||
(activate-readline)
|
||||
|
||||
.SH "SEE ALSO"
|
||||
.B info guile, info guile-tut
|
||||
The full documentation for guile is maintained as a Texinfo manual. If
|
||||
the info and guile programs are properly installed at your site, the
|
||||
command
|
||||
.IP
|
||||
.B info guile
|
||||
.PP
|
||||
should give you access to the complete manual.
|
||||
|
||||
http://www.schemers.org provides a general introduction to the
|
||||
Scheme language.
|
||||
|
|
|
|||
|
|
@ -23,6 +23,4 @@ AUTOMAKE_OPTIONS = gnu
|
|||
|
||||
info_TEXINFOS = r5rs.texi
|
||||
|
||||
TEXINFO_TEX = ../ref/texinfo.tex
|
||||
|
||||
EXTRA_DIST = ChangeLog-2008
|
||||
|
|
|
|||
|
|
@ -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, 2007
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
|
|
@ -19,7 +19,6 @@ infrastructure that builds on top of those calls.
|
|||
* Evaluation Model:: Evaluation and the Scheme stack.
|
||||
* Debug on Error:: Debugging when an error occurs.
|
||||
* Traps::
|
||||
* Breakpoints::
|
||||
* Debugging Examples::
|
||||
@end menu
|
||||
|
||||
|
|
@ -1691,137 +1690,6 @@ if there isn't one.
|
|||
@end deffn
|
||||
|
||||
|
||||
@node Breakpoints
|
||||
@subsection Breakpoints
|
||||
|
||||
While they are an important piece of infrastructure, and directly
|
||||
usable in some scenarios, traps are still too low level to meet some
|
||||
of the requirements of interactive development.
|
||||
|
||||
A common scenario is that a newly written procedure is not working
|
||||
properly, and so you'd like to be able to step or trace through its
|
||||
code to find out why. Ideally this should be possible from the IDE
|
||||
and without having to modify the source code. There are two problems
|
||||
with using traps directly in this scenario.
|
||||
|
||||
@enumerate
|
||||
@item
|
||||
They are too detailed: constructing and installing a trap requires you
|
||||
to say what kind of trap you want and to specify fairly low level
|
||||
options for it, whereas what you really want is just to say ``break
|
||||
here using the most efficient means possible.''
|
||||
|
||||
@item
|
||||
The most efficient kinds of trap --- that is, @code{<procedure-trap>}
|
||||
and @code{<source-trap>} --- can only be specified and installed
|
||||
@emph{after} the code that they refer to has been loaded. This is an
|
||||
inconvenient detail for the user to deal with, and in some
|
||||
applications it might be very difficult to insert an instruction to
|
||||
install the required trap in between when the code is loaded and when
|
||||
the procedure concerned is first called. It would be better to be
|
||||
able to tell Guile about the requirement upfront, and for it to deal
|
||||
with installing the trap when possible.
|
||||
@end enumerate
|
||||
|
||||
We solve these problems by introducing breakpoints. A breakpoint is
|
||||
something which says ``I want to break at location X, or in procedure
|
||||
P --- just make it happen'', and can be set regardless of whether the
|
||||
relevant code has already been loaded. Breakpoints use traps to do
|
||||
their work, but that is a detail that the user will usually not have
|
||||
to care about.
|
||||
|
||||
Breakpoints are provided by a combination of Scheme code in the client
|
||||
program, and facilities for setting and managing breakpoints in the
|
||||
GDS front end. On the Scheme side the entry points are as follows.
|
||||
|
||||
@deffn {Getter with Setter} default-breakpoint-behaviour
|
||||
A ``getter with setter'' procedure that can be used to get or set the
|
||||
default behaviour for new breakpoints. When a new default behaviour
|
||||
is set, by calling
|
||||
|
||||
@lisp
|
||||
(set! (default-breakpoint-behaviour) @var{new-behaviour})
|
||||
@end lisp
|
||||
|
||||
@noindent
|
||||
the new behaviour applies to all following @code{break-in} and
|
||||
@code{break-at} calls, but does not affect breakpoints which have
|
||||
already been set. @var{new-behaviour} should be a behaviour procedure
|
||||
with the signature
|
||||
|
||||
@lisp
|
||||
(lambda (trap-context) @dots{})
|
||||
@end lisp
|
||||
|
||||
@noindent
|
||||
as described in @ref{Specifying Trap Behaviour}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Procedure} break-in procedure-name [module-or-file-name] [options]
|
||||
Set a breakpoint on entry to the procedure named @var{procedure-name},
|
||||
which should be a symbol. @var{module-or-file-name}, if present, is
|
||||
the name of the module (a list of symbols) or file (a string) which
|
||||
includes the target procedure. If @var{module-or-file-name} is
|
||||
absent, the target procedure is assumed to be in the current module.
|
||||
|
||||
The available options are any of the common trap options
|
||||
(@pxref{Common Trap Options}), and are used when creating the
|
||||
breakpoint's underlying traps. The default breakpoint behaviour
|
||||
(given earlier to @code{default-breakpoint-behaviour}) is only used if
|
||||
these options do not include @code{#:behaviour @var{behaviour}}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Procedure} break-at file-name line column [options]
|
||||
Set a breakpoint on the expression in file @var{file-name} whose
|
||||
opening parenthesis is on line @var{line} at column @var{column}.
|
||||
@var{line} and @var{column} both count from 0 (not from 1).
|
||||
|
||||
The available options are any of the common trap options
|
||||
(@pxref{Common Trap Options}), and are used when creating the
|
||||
breakpoint's underlying traps. The default breakpoint behaviour
|
||||
(given earlier to @code{default-breakpoint-behaviour}) is only used if
|
||||
these options do not include @code{#:behaviour @var{behaviour}}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Procedure} set-gds-breakpoints
|
||||
Ask the GDS front end for a list of breakpoints to set, and set these
|
||||
using @code{break-in} and @code{break-at} as appropriate.
|
||||
@end deffn
|
||||
|
||||
@code{default-breakpoint-behaviour}, @code{break-in} and
|
||||
@code{break-at} allow an application's startup code to specify any
|
||||
breakpoints that it needs inline in that code. For example, to trace
|
||||
calls and arguments to a group of procedures to handle HTTP requests,
|
||||
one might write something like this:
|
||||
|
||||
@lisp
|
||||
(use-modules (ice-9 debugging breakpoints)
|
||||
(ice-9 debugging trace))
|
||||
|
||||
(set! (default-breakpoint-behaviour) trace-trap)
|
||||
|
||||
(break-in 'handle-http-request '(web http))
|
||||
(break-in 'read-http-request '(web http))
|
||||
(break-in 'decode-form-data '(web http))
|
||||
(break-in 'send-http-response '(web http))
|
||||
@end lisp
|
||||
|
||||
@code{set-gds-breakpoints} can be used as well as or instead of the
|
||||
above, and is intended to be the most practical option if you are
|
||||
using GDS. The idea is that you only need to add this one call
|
||||
somewhere in your application's startup code, like this:
|
||||
|
||||
@lisp
|
||||
(use-modules (ice-9 gds-client))
|
||||
(set-gds-breakpoints)
|
||||
@end lisp
|
||||
|
||||
@noindent
|
||||
and then all the details of the breakpoints that you want to set can
|
||||
be managed through GDS. For the details of GDS's breakpoints
|
||||
interface, see @ref{Setting and Managing Breakpoints}.
|
||||
|
||||
|
||||
@node Debugging Examples
|
||||
@subsection Debugging Examples
|
||||
|
||||
|
|
|
|||
|
|
@ -420,8 +420,7 @@ purpose to check whether your code still relies on them.
|
|||
@section Reporting Bugs
|
||||
|
||||
Any problems with the installation should be reported to
|
||||
@email{bug-guile@@gnu.org}. Please note that you must be subscribed to
|
||||
this list first, in order to successfully send a report to it.
|
||||
@email{bug-guile@@gnu.org}.
|
||||
|
||||
Whenever you have found a bug in Guile you are encouraged to report it
|
||||
to the Guile developers, so they can fix it. They may also be able to
|
||||
|
|
|
|||
|
|
@ -485,9 +485,9 @@ popping up in a temporary Emacs window.
|
|||
@end itemize
|
||||
|
||||
@item
|
||||
Debugging a Guile Scheme program. When your program hits an error or a
|
||||
breakpoint, GDS shows you the relevant code and the Scheme stack, and
|
||||
makes it easy to
|
||||
Debugging a Guile Scheme program. When your program hits an error or
|
||||
stops at a trap, GDS shows you the relevant code and the Scheme stack,
|
||||
and makes it easy to
|
||||
|
||||
@itemize
|
||||
@item
|
||||
|
|
@ -495,9 +495,6 @@ look at the values of local variables
|
|||
@item
|
||||
see what is happening at all levels of the Scheme stack
|
||||
@item
|
||||
set new breakpoints (by simply typing @kbd{C-x @key{SPC}}) or modify
|
||||
existing ones
|
||||
@item
|
||||
continue execution, either normally or step by step.
|
||||
@end itemize
|
||||
|
||||
|
|
@ -509,13 +506,6 @@ Guile to run until that frame completes, at which point GDS will display
|
|||
the frame's return value.
|
||||
@end enumerate
|
||||
|
||||
Combinations of these well too. You can evaluate a fragment of code (in
|
||||
a Scheme buffer) that contains a breakpoint, then use the debugging
|
||||
interface to step through the code at the breakpoint. You can also run
|
||||
a program until it hits a breakpoint, then examine, modify and
|
||||
reevaluate some of the relevant code, and then tell the program to
|
||||
continue running.
|
||||
|
||||
GDS can provide these facilities for any number of Guile Scheme programs
|
||||
(which we often refer to as ``clients'') at once, and these programs can
|
||||
be started either independently of GDS, including outside Emacs, or
|
||||
|
|
@ -638,63 +628,16 @@ act on instructions from GDS, and we refer to it as a @dfn{utility}
|
|||
Guile client. Over time this utility client will accumulate the code
|
||||
that you ask it to evaluate, and you can also tell it to load complete
|
||||
files or modules by sending it @code{load} or @code{use-modules}
|
||||
expressions. You can set breakpoints and evaluate code which hits those
|
||||
breakpoints, and GDS will pop up the stack at the breakpoint so you can
|
||||
explore your code by single-stepping and evaluating test expressions.
|
||||
For a hands-on, tutorial introduction to using GDS in this way, use
|
||||
Emacs to open the file @file{gds-tutorial.txt} (which should have been
|
||||
installed as part of Guile, perhaps under @file{/usr/share/doc/guile}),
|
||||
and then follow the steps in that file.
|
||||
expressions.
|
||||
|
||||
When you want to use GDS to work on an independent Guile
|
||||
application, you need to add something to that application's Scheme code
|
||||
to cause it to connect to and interact with GDS at the right times. The
|
||||
following subsections describe the ways of doing this.
|
||||
|
||||
@subsubsection Setting Specific Breakpoints
|
||||
|
||||
The first option is to use @code{break-in} or @code{break-at} to set
|
||||
specific breakpoints in the application's code. This requires code like
|
||||
the following.
|
||||
|
||||
@lisp
|
||||
(use-modules (ice-9 debugging breakpoints)
|
||||
(ice-9 gds-client))
|
||||
|
||||
(break-in 'fact2 "ice-9/debugging/example-fns"
|
||||
#:behaviour gds-debug-trap)
|
||||
(break-in 'facti "ice-9/debugging/example-fns"
|
||||
#:behaviour gds-debug-trap)
|
||||
@end lisp
|
||||
|
||||
@noindent
|
||||
The @code{#:behaviour gds-debug-trap} clauses mean to use GDS to
|
||||
display the stack when one of these breakpoints is hit. For more on
|
||||
breakpoints, @code{break-in} and @code{break-at}, see
|
||||
@ref{Breakpoints}.
|
||||
|
||||
@subsubsection Setting GDS-managed Breakpoints
|
||||
|
||||
Instead of listing specific breakpoints in application code, you can use
|
||||
GDS to manage the set of breakpoints that you want from Emacs, and tell
|
||||
the application to download the breakpoints that it should set from
|
||||
GDS. The code for this is:
|
||||
|
||||
@lisp
|
||||
(use-modules (ice-9 gds-client))
|
||||
(set-gds-breakpoints)
|
||||
@end lisp
|
||||
|
||||
These lines tell the program to connect to GDS immediately and download
|
||||
a set of breakpoint definitions. The program sets those breakpoints in
|
||||
its code, then continues running.
|
||||
|
||||
When the program later hits one of the breakpoints, it will use GDS to
|
||||
display the stack and wait for instruction on what to do next.
|
||||
|
||||
@subsubsection Invoking GDS when an Exception Occurs
|
||||
|
||||
Another option is to use GDS to catch and display any exceptions that
|
||||
One option is to use GDS to catch and display any exceptions that
|
||||
are thrown by the application's code. If you already have a
|
||||
@code{lazy-catch} or @code{with-throw-handler} around the area of code
|
||||
that you want to monitor, you just need to add the following to the
|
||||
|
|
@ -749,12 +692,12 @@ hits an exception that is protected by a @code{lazy-catch} using
|
|||
|
||||
@subsubsection Accepting GDS Instructions at Any Time
|
||||
|
||||
In addition to setting breakpoints and/or an exception handler as
|
||||
described above, a Guile program can in principle set itself up to
|
||||
accept new instructions from GDS at any time, not just when it has
|
||||
stopped at a breakpoint or exception. This would allow the GDS user to
|
||||
set new breakpoints or to evaluate code in the context of the running
|
||||
program, without having to wait for the program to stop first.
|
||||
In addition to setting an exception handler as described above, a
|
||||
Guile program can in principle set itself up to accept new
|
||||
instructions from GDS at any time, not just when it has stopped at an
|
||||
exception. This would allow the GDS user to evaluate code in the
|
||||
context of the running program, without having to wait for the program
|
||||
to stop first.
|
||||
|
||||
@lisp
|
||||
(use-modules (ice-9 gds-client))
|
||||
|
|
@ -793,13 +736,11 @@ the utility Guile client is essentially just this:
|
|||
|
||||
@lisp
|
||||
(use-modules (ice-9 gds-client))
|
||||
(set-gds-breakpoints)
|
||||
(named-module-use! '(guile-user) '(ice-9 session))
|
||||
(gds-accept-input #f))
|
||||
@end lisp
|
||||
|
||||
@code{set-gds-breakpoints} works as already described. The
|
||||
@code{named-module-use!} line ensures that the client can process
|
||||
The @code{named-module-use!} line ensures that the client can process
|
||||
@code{help} and @code{apropos} expressions, to implement lookups in
|
||||
Guile's online help. The @code{#f} parameter to
|
||||
@code{gds-accept-input} means that the @code{continue} instruction
|
||||
|
|
@ -827,9 +768,6 @@ GDS provides for working on code in @code{scheme-mode} buffers.
|
|||
|
||||
@menu
|
||||
* Access to Guile Help and Completion::
|
||||
* Setting and Managing Breakpoints::
|
||||
* Listing and Deleting Breakpoints::
|
||||
* Moving and Losing Breakpoints::
|
||||
* Evaluating Scheme Code::
|
||||
@end menu
|
||||
|
||||
|
|
@ -872,90 +810,6 @@ selected using either @kbd{@key{RET}} or the mouse.
|
|||
@end table
|
||||
|
||||
|
||||
@node Setting and Managing Breakpoints
|
||||
@subsubsection Setting and Managing Breakpoints
|
||||
|
||||
You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a
|
||||
Scheme mode buffer. To create a breakpoint on calls to a procedure ---
|
||||
i.e. the equivalent of calling @code{break-in} --- place the cursor
|
||||
anywhere within the procedure's definition, make sure that the region is
|
||||
unset, and type @kbd{C-x @key{SPC}}. To create breakpoints on a
|
||||
particular expression, or on the series of expressions in a particular
|
||||
region --- i.e. as with @code{break-at} --- select a region containing
|
||||
the open parentheses of the expressions where you want breakpoints, and
|
||||
type @kbd{C-x @key{SPC}}. In other words, GDS assumes that you want a
|
||||
@code{break-at} breakpoint if there is an active region, and a
|
||||
@code{break-in} breakpoint otherwise.
|
||||
|
||||
There are three supported breakpoint behaviours, known as @code{debug},
|
||||
@code{trace} and @code{trace-subtree}. @code{debug} means that GDS will
|
||||
display the stack and wait for instruction when the breakpoint is hit.
|
||||
@code{trace} means that a line will be written to the trace output
|
||||
buffer (@code{*GDS Trace*}) when the breakpoint is hit, and when the
|
||||
relevant expression or procedure call returns. @code{trace-subtree}
|
||||
means that a line is written to the trace output buffer for every
|
||||
evaluation step between when the breakpoint is hit and when the
|
||||
expression or procedure returns.
|
||||
|
||||
@kbd{C-x @key{SPC}} creates a breakpoint with behaviour according to the
|
||||
@code{gds-default-breakpoint-type} variable, which by default is
|
||||
@code{debug}; you can customize this if you prefer a different default.
|
||||
You can also create a breakpoint with behaviour other than the current
|
||||
default by using the alternative key sequences @kbd{C-c C-b d} (for
|
||||
@code{debug}), @kbd{C-c C-b t} (for @code{trace}) and @kbd{C-c C-b T}
|
||||
(for @code{trace-subtree}).
|
||||
|
||||
GDS keeps all the breakpoints that you create in a single list, and
|
||||
tries to set them in every Guile program that connects to GDS and calls
|
||||
@code{set-gds-breakpoints}. That may sound surprising, because you are
|
||||
probably thinking of one particular program when you create a
|
||||
breakpoint; but GDS assumes that you would want the breakpoint to continue
|
||||
taking effect if you stop and restart that program, and this is
|
||||
currently achieved by giving all breakpoints to every program that asks
|
||||
for them. In practice it doesn't matter if a program gets a breakpoint
|
||||
definition --- such as ``break in procedure @code{foo}'' --- that it
|
||||
can't actually map to any of its code.
|
||||
|
||||
If there are already Guile programs connected to GDS when you create a
|
||||
new breakpoint, GDS also tries to set the new breakpoint in each of
|
||||
those programs at the earliest opportunity, which is usually when they
|
||||
decide to stop and talk to GDS for some other reason.
|
||||
|
||||
|
||||
@node Listing and Deleting Breakpoints
|
||||
@subsubsection Listing and Deleting Breakpoints
|
||||
|
||||
To see a list of all breakpoints, type @kbd{C-c C-b ?} (or @kbd{M-x
|
||||
gds-describe-breakpoints}). GDS will then pop up a buffer that
|
||||
describes each breakpoint and reports whether it is actually set in each
|
||||
of the Guile programs connected to GDS.
|
||||
|
||||
To delete a breakpoint, type @kbd{C-c C-b @key{backspace}}. If the
|
||||
region is active when you do this, GDS will delete all of the
|
||||
breakpoints in the region. If the region is not active, GDS tries to
|
||||
delete a ``break-in'' breakpoint for the procedure whose definition
|
||||
contains point (the Emacs cursor). In either case, deletion means that
|
||||
the breakpoint is removed both from GDS's global list and from all of
|
||||
the connected Guile programs that had previously managed to set it.
|
||||
|
||||
|
||||
@node Moving and Losing Breakpoints
|
||||
@subsubsection Moving and Losing Breakpoints
|
||||
|
||||
Imagine that you set a breakpoint at line 80 of a Scheme code file, and
|
||||
execute some code that hits this breakpoint; then you add some new code
|
||||
at line 40, or delete some code that is no longer needed, and save the
|
||||
file. Now the breakpoint will have moved up or down from line 80, and
|
||||
any attached Guile program needs to be told about the new line number.
|
||||
Otherwise, when a program loads this file again, it will try incorrectly
|
||||
to set a breakpoint on whatever code is now at line 80, and will
|
||||
@emph{not} set a breakpoint on the code where you want it.
|
||||
|
||||
For this reason, GDS checks all breakpoint positions whenever you save a
|
||||
Scheme file, and sends the new position to connected Guile programs for
|
||||
any breakpoints that have moved. @dots{} [to be continued]
|
||||
|
||||
|
||||
@node Evaluating Scheme Code
|
||||
@subsubsection Evaluating Scheme Code
|
||||
|
||||
|
|
@ -1000,15 +854,15 @@ are described in the next two sections.
|
|||
@node Displaying the Scheme Stack
|
||||
@subsection Displaying the Scheme Stack
|
||||
|
||||
When you specify @code{gds-debug-trap} as the behaviour for a trap or
|
||||
a breakpoint and the Guile program concerned hits that trap or
|
||||
breakpoint, GDS displays the stack and the relevant Scheme source code
|
||||
in Emacs, allowing you to explore the state of the program and then
|
||||
decide what to do next. The same applies if the program calls
|
||||
@code{(on-lazy-handler-dispatch gds-debug-trap)} and then throws an
|
||||
exception that passes through @code{lazy-handler-dispatch}, except
|
||||
that in this case you can only explore; it isn't possible to continue
|
||||
normal execution after an exception.
|
||||
When you specify @code{gds-debug-trap} as the behaviour for a trap and
|
||||
the Guile program concerned hits that trap, GDS displays the stack and
|
||||
the relevant Scheme source code in Emacs, allowing you to explore the
|
||||
state of the program and then decide what to do next. The same
|
||||
applies if the program calls @code{(on-lazy-handler-dispatch
|
||||
gds-debug-trap)} and then throws an exception that passes through
|
||||
@code{lazy-handler-dispatch}, except that in this case you can only
|
||||
explore; it isn't possible to continue normal execution after an
|
||||
exception.
|
||||
|
||||
The following commands are available in the stack buffer for exploring
|
||||
the state of the program.
|
||||
|
|
|
|||
|
|
@ -23,6 +23,4 @@ AUTOMAKE_OPTIONS = gnu
|
|||
|
||||
info_TEXINFOS = guile-tut.texi
|
||||
|
||||
TEXINFO_TEX = ../ref/texinfo.tex
|
||||
|
||||
EXTRA_DIST = ChangeLog-2008
|
||||
|
|
|
|||
|
|
@ -484,483 +484,6 @@ interesting happened, `nil' if not."
|
|||
(display-completion-list gds-completion-results))
|
||||
t)))))
|
||||
|
||||
;;;; Breakpoints.
|
||||
|
||||
(defvar gds-bufferless-breakpoints nil
|
||||
"The list of breakpoints that are not yet associated with a
|
||||
particular buffer. Each element looks like (BPDEF BPNUM) where BPDEF
|
||||
is the breakpoint definition and BPNUM the breakpoint's unique
|
||||
GDS-assigned number. A breakpoint definition BPDEF is a list of the
|
||||
form (BEHAVIOUR TYPE FILENAME TYPE-ARGS...), where BEHAVIOUR is 'debug
|
||||
or 'trace, TYPE is 'in or 'at, FILENAME is the full name of the file
|
||||
where the breakpoint is (or will be) set, and TYPE-ARGS is:
|
||||
|
||||
- the name of the procedure to break in, if TYPE is 'in
|
||||
|
||||
- the line number and column number to break at, if TYPE is 'at.
|
||||
|
||||
If persistent breakpoints are enabled (by configuring
|
||||
gds-breakpoints-file-name), this list is initialized when GDS is
|
||||
loaded by reading gds-breakpoints-file-name.")
|
||||
|
||||
(defsubst gds-bpdef:behaviour (bpdef)
|
||||
(nth 0 bpdef))
|
||||
|
||||
(defsubst gds-bpdef:type (bpdef)
|
||||
(nth 1 bpdef))
|
||||
|
||||
(defsubst gds-bpdef:file-name (bpdef)
|
||||
(nth 2 bpdef))
|
||||
|
||||
(defsubst gds-bpdef:proc-name (bpdef)
|
||||
(nth 3 bpdef))
|
||||
|
||||
(defsubst gds-bpdef:lc (bpdef)
|
||||
(nth 3 bpdef))
|
||||
|
||||
(defvar gds-breakpoint-number 0
|
||||
"The last assigned breakpoint number. GDS increments this whenever
|
||||
it creates a new breakpoint.")
|
||||
|
||||
(defvar gds-breakpoint-buffers nil
|
||||
"The list of buffers that contain GDS breakpoints. When Emacs
|
||||
visits a Scheme file, GDS checks to see if any of the breakpoints in
|
||||
the bufferless list can be assigned to that file's buffer. If they
|
||||
can, they are removed from the bufferless list and become breakpoint
|
||||
overlays in that buffer. To retain the ability to enumerate all
|
||||
breakpoints, therefore, we keep a list of all such buffers.")
|
||||
|
||||
(defvar gds-breakpoint-programming nil
|
||||
"Information about how each breakpoint is actually programmed in the
|
||||
Guile clients that GDS is connected to. This is an alist of the form
|
||||
\((BPNUM (CLIENT . TRAPLIST) ...) ...), where BPNUM is the breakpoint
|
||||
number, CLIENT is the number of a GDS client, and TRAPLIST is the list
|
||||
of traps that that client has created for the breakpoint concerned (in
|
||||
an arbitrary but Emacs-readable format).")
|
||||
|
||||
(defvar gds-breakpoint-cache nil
|
||||
"Buffer-local cache of breakpoints in a particular buffer. When a
|
||||
breakpoint is represented as an overlay is a Scheme mode buffer, we
|
||||
need to be able to detect when the user has caused that overlay to
|
||||
evaporate by deleting a region of code that included it. We do this
|
||||
detection when the buffer is next saved, by comparing the current set
|
||||
of overlays with this cache. The cache is a list in which each
|
||||
element has the form (BPDEF BPNUM), with BPDEF and BPNUM as already
|
||||
described. The handling of such breakpoints (which we call \"lost\")
|
||||
is controlled by the setting of gds-delete-lost-breakpoints.")
|
||||
(make-variable-buffer-local 'gds-breakpoint-cache)
|
||||
|
||||
(defface gds-breakpoint-face
|
||||
'((((background dark)) (:background "red"))
|
||||
(t (:background "pink")))
|
||||
"*Face used to highlight the location of a breakpoint."
|
||||
:group 'gds)
|
||||
|
||||
(defcustom gds-breakpoints-file-name "~/.gds-breakpoints"
|
||||
"Name of file used to store GDS breakpoints between sessions.
|
||||
You can disable breakpoint persistence by setting this to nil."
|
||||
:group 'gds
|
||||
:type '(choice (const :tag "nil" nil) file))
|
||||
|
||||
(defcustom gds-delete-lost-breakpoints nil
|
||||
"Whether to delete lost breakpoints.
|
||||
|
||||
A non-nil value means that the Guile clients where lost breakpoints
|
||||
were programmed will be told immediately to delete their breakpoints.
|
||||
\"Immediately\" means when the lost breakpoints are detected, which
|
||||
means when the buffer that previously contained them is saved. Thus,
|
||||
even if the affected code (which the GDS user has deleted from his/her
|
||||
buffer in Emacs) is still in use in the Guile clients, the breakpoints
|
||||
that were previously set in that code will no longer take effect.
|
||||
|
||||
Nil (which is the default) means that GDS leaves such breakpoints
|
||||
active in their Guile clients. This allows those breakpoints to
|
||||
continue taking effect until the affected code is no longer used by
|
||||
the Guile clients."
|
||||
:group 'gds
|
||||
:type 'boolean)
|
||||
|
||||
(defvar gds-bpdefs-cache nil)
|
||||
|
||||
(defun gds-read-breakpoints-file ()
|
||||
"Read the persistent breakpoints file, and use its contents to
|
||||
initialize GDS's global breakpoint variables."
|
||||
(let ((bpdefs (condition-case nil
|
||||
(with-current-buffer
|
||||
(find-file-noselect gds-breakpoints-file-name)
|
||||
(goto-char (point-min))
|
||||
(read (current-buffer)))
|
||||
(error nil))))
|
||||
;; Cache the overall value so we don't unnecessarily modify the
|
||||
;; breakpoints buffer when `gds-write-breakpoints-file' is called.
|
||||
(setq gds-bpdefs-cache bpdefs)
|
||||
;; Move definitions into the bufferless breakpoint list, assigning
|
||||
;; breakpoint numbers as we go.
|
||||
(setq gds-bufferless-breakpoints
|
||||
(mapcar (function (lambda (bpdef)
|
||||
(setq gds-breakpoint-number
|
||||
(1+ gds-breakpoint-number))
|
||||
(list bpdef gds-breakpoint-number)))
|
||||
bpdefs))
|
||||
;; Check each existing Scheme buffer to see if it wants to take
|
||||
;; ownership of any of these breakpoints.
|
||||
(mapcar (function (lambda (buffer)
|
||||
(with-current-buffer buffer
|
||||
(if (eq (derived-mode-class major-mode) 'scheme-mode)
|
||||
(gds-adopt-breakpoints)))))
|
||||
(buffer-list))))
|
||||
|
||||
(defun gds-adopt-breakpoints ()
|
||||
"Take ownership of any of the breakpoints in the bufferless list
|
||||
that match the current buffer."
|
||||
(mapcar (function gds-adopt-breakpoint)
|
||||
(copy-sequence gds-bufferless-breakpoints)))
|
||||
|
||||
(defun gds-adopt-breakpoint (bpdefnum)
|
||||
"Take ownership of the specified breakpoint if it matches the
|
||||
current buffer."
|
||||
(let ((bpdef (car bpdefnum))
|
||||
(bpnum (cadr bpdefnum)))
|
||||
;; Check if breakpoint's file name matches. If it does, try to
|
||||
;; convert the breakpoint definition to a breakpoint overlay in
|
||||
;; the current buffer.
|
||||
(if (and (string-equal (gds-bpdef:file-name bpdef) buffer-file-name)
|
||||
(gds-make-breakpoint-overlay bpdef bpnum))
|
||||
;; That all succeeded, so this breakpoint is no longer
|
||||
;; bufferless.
|
||||
(setq gds-bufferless-breakpoints
|
||||
(delq bpdefnum gds-bufferless-breakpoints)))))
|
||||
|
||||
(defun gds-make-breakpoint-overlay (bpdef &optional bpnum)
|
||||
;; If no explicit number given, assign the next available breakpoint
|
||||
;; number.
|
||||
(or bpnum
|
||||
(setq gds-breakpoint-number (+ gds-breakpoint-number 1)
|
||||
bpnum gds-breakpoint-number))
|
||||
;; First decide where the overlay should be, and create it there.
|
||||
(let ((o (cond ((eq (gds-bpdef:type bpdef) 'at)
|
||||
(save-excursion
|
||||
(goto-line (+ (car (gds-bpdef:lc bpdef)) 1))
|
||||
(move-to-column (cdr (gds-bpdef:lc bpdef)))
|
||||
(make-overlay (point) (1+ (point)))))
|
||||
((eq (gds-bpdef:type bpdef) 'in)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(and (re-search-forward (concat "^(define +(?\\("
|
||||
(regexp-quote
|
||||
(gds-bpdef:proc-name
|
||||
bpdef))
|
||||
"\\>\\)")
|
||||
nil t)
|
||||
(make-overlay (match-beginning 1) (match-end 1)))))
|
||||
(t
|
||||
(error "Bad breakpoint type")))))
|
||||
;; If that succeeded, initialize the overlay's properties.
|
||||
(if o
|
||||
(progn
|
||||
(overlay-put o 'evaporate t)
|
||||
(overlay-put o 'face 'gds-breakpoint-face)
|
||||
(overlay-put o 'gds-breakpoint-number bpnum)
|
||||
(overlay-put o 'gds-breakpoint-definition bpdef)
|
||||
(overlay-put o 'help-echo (format "Breakpoint %d: %S" bpnum bpdef))
|
||||
(overlay-put o 'priority 1000)
|
||||
;; Make sure that the current buffer is included in
|
||||
;; `gds-breakpoint-buffers'.
|
||||
(or (memq (current-buffer) gds-breakpoint-buffers)
|
||||
(setq gds-breakpoint-buffers
|
||||
(cons (current-buffer) gds-breakpoint-buffers)))
|
||||
;; Add the new breakpoint to this buffer's cache.
|
||||
(setq gds-breakpoint-cache
|
||||
(cons (list bpdef bpnum) gds-breakpoint-cache))
|
||||
;; If this buffer is associated with a client, tell the
|
||||
;; client about the new breakpoint.
|
||||
(if gds-client (gds-send-breakpoint-to-client bpnum bpdef))))
|
||||
;; Return the overlay, or nil if we weren't able to convert the
|
||||
;; breakpoint definition.
|
||||
o))
|
||||
|
||||
(defun gds-send-breakpoint-to-client (bpnum bpdef)
|
||||
"Send specified breakpoint to this buffer's Guile client."
|
||||
(gds-send (format "set-breakpoint %d %S" bpnum bpdef) gds-client))
|
||||
|
||||
(add-hook 'scheme-mode-hook (function gds-adopt-breakpoints))
|
||||
|
||||
(defcustom gds-default-breakpoint-type 'debug
|
||||
"The type of breakpoint set by `C-x SPC'."
|
||||
:group 'gds
|
||||
:type '(choice (const :tag "debug" debug) (const :tag "trace" trace)))
|
||||
|
||||
(defun gds-set-breakpoint ()
|
||||
"Create a new GDS breakpoint at point."
|
||||
(interactive)
|
||||
;; Set up beg and end according to whether the mark is active.
|
||||
(if mark-active
|
||||
;; Set new breakpoints on all opening parentheses in the region.
|
||||
(let ((beg (region-beginning))
|
||||
(end (region-end)))
|
||||
(save-excursion
|
||||
(goto-char beg)
|
||||
(beginning-of-defun)
|
||||
(let ((defun-start (point)))
|
||||
(goto-char beg)
|
||||
(while (search-forward "(" end t)
|
||||
(let ((state (parse-partial-sexp defun-start (point)))
|
||||
(pos (- (point) 1)))
|
||||
(or (nth 3 state)
|
||||
(nth 4 state)
|
||||
(gds-breakpoint-overlays-at pos)
|
||||
(gds-make-breakpoint-overlay (list gds-default-breakpoint-type
|
||||
'at
|
||||
buffer-file-name
|
||||
(gds-line-and-column
|
||||
pos)))))))))
|
||||
;; Set a new breakpoint on the defun at point.
|
||||
(let ((region (gds-defun-name-region)))
|
||||
;; Complain if there is no defun at point.
|
||||
(or region
|
||||
(error "Point is not in a procedure definition"))
|
||||
;; Don't create another breakpoint if there is already one here.
|
||||
(if (gds-breakpoint-overlays-at (car region))
|
||||
(error "There is already a breakpoint here"))
|
||||
;; Create and return the new breakpoint overlay.
|
||||
(gds-make-breakpoint-overlay (list gds-default-breakpoint-type
|
||||
'in
|
||||
buffer-file-name
|
||||
(buffer-substring-no-properties
|
||||
(car region)
|
||||
(cdr region))))))
|
||||
;; Update the persistent breakpoints file.
|
||||
(gds-write-breakpoints-file))
|
||||
|
||||
(defun gds-defun-name-region ()
|
||||
"If point is in a defun, return the beginning and end positions of
|
||||
the identifier being defined."
|
||||
(save-excursion
|
||||
(let ((p (point)))
|
||||
(beginning-of-defun)
|
||||
;; Check that we are looking at some kind of procedure
|
||||
;; definition.
|
||||
(and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)")
|
||||
(let ((beg (match-beginning 1))
|
||||
(end (match-end 1)))
|
||||
(end-of-defun)
|
||||
;; Check here that we have reached past the original point
|
||||
;; position.
|
||||
(and (>= (point) p)
|
||||
(cons beg end)))))))
|
||||
|
||||
(defun gds-breakpoint-overlays-at (pos)
|
||||
"Return a list of GDS breakpoint overlays at the specified position."
|
||||
(let ((os (overlays-at pos))
|
||||
(breakpoint-os nil))
|
||||
;; Of the overlays at POS, select all those that have a
|
||||
;; gds-breakpoint-definition property.
|
||||
(while os
|
||||
(if (overlay-get (car os) 'gds-breakpoint-definition)
|
||||
(setq breakpoint-os (cons (car os) breakpoint-os)))
|
||||
(setq os (cdr os)))
|
||||
breakpoint-os))
|
||||
|
||||
(defun gds-write-breakpoints-file ()
|
||||
"Write the persistent breakpoints file, if configured."
|
||||
(if gds-breakpoints-file-name
|
||||
(let ((bpdefs (gds-fold-breakpoints (function (lambda (bpnum bpdef init)
|
||||
(cons bpdef init)))
|
||||
t)))
|
||||
(or (equal bpdefs gds-bpdefs-cache)
|
||||
(with-current-buffer (find-file-noselect gds-breakpoints-file-name)
|
||||
(erase-buffer)
|
||||
(pp (reverse bpdefs) (current-buffer))
|
||||
(setq gds-bpdefs-cache bpdefs)
|
||||
(let ((auto-fill-function normal-auto-fill-function))
|
||||
(newline)))))))
|
||||
|
||||
(defun gds-fold-breakpoints (fn &optional foldp init)
|
||||
;; Run through bufferless breakpoints first.
|
||||
(let ((bbs gds-bufferless-breakpoints))
|
||||
(while bbs
|
||||
(let ((bpnum (cadr (car bbs)))
|
||||
(bpdef (caar bbs)))
|
||||
(if foldp
|
||||
(setq init (funcall fn bpnum bpdef init))
|
||||
(funcall fn bpnum bpdef)))
|
||||
(setq bbs (cdr bbs))))
|
||||
;; Now run through breakpoint buffers.
|
||||
(let ((outbuf (current-buffer))
|
||||
(bpbufs gds-breakpoint-buffers))
|
||||
(while bpbufs
|
||||
(let ((buf (car bpbufs)))
|
||||
(if (buffer-live-p buf)
|
||||
(with-current-buffer buf
|
||||
(save-restriction
|
||||
(widen)
|
||||
(let ((os (overlays-in (point-min) (point-max))))
|
||||
(while os
|
||||
(let ((bpnum (overlay-get (car os)
|
||||
'gds-breakpoint-number))
|
||||
(bpdef (overlay-get (car os)
|
||||
'gds-breakpoint-definition)))
|
||||
(if bpdef
|
||||
(with-current-buffer outbuf
|
||||
(if foldp
|
||||
(setq init (funcall fn bpnum bpdef init))
|
||||
(funcall fn bpnum bpdef)))))
|
||||
(setq os (cdr os))))))))
|
||||
(setq bpbufs (cdr bpbufs))))
|
||||
init)
|
||||
|
||||
(defun gds-delete-breakpoints ()
|
||||
"Delete GDS breakpoints in the region or at point."
|
||||
(interactive)
|
||||
(if mark-active
|
||||
;; Delete all breakpoints in the region.
|
||||
(let ((os (overlays-in (region-beginning) (region-end))))
|
||||
(while os
|
||||
(if (overlay-get (car os) 'gds-breakpoint-definition)
|
||||
(gds-delete-breakpoint (car os)))
|
||||
(setq os (cdr os))))
|
||||
;; Delete the breakpoint "at point".
|
||||
(call-interactively (function gds-delete-breakpoint))))
|
||||
|
||||
(defun gds-delete-breakpoint (o)
|
||||
(interactive (list (or (gds-breakpoint-at-point)
|
||||
(error "There is no breakpoint here"))))
|
||||
(let ((bpdef (overlay-get o 'gds-breakpoint-definition))
|
||||
(bpnum (overlay-get o 'gds-breakpoint-number)))
|
||||
;; If this buffer is associated with a client, tell the client
|
||||
;; that the breakpoint has been deleted.
|
||||
(if (and bpnum gds-client)
|
||||
(gds-send (format "delete-breakpoint %d" bpnum) gds-client))
|
||||
;; Remove this breakpoint from the cache also, so it isn't later
|
||||
;; detected as having been "lost".
|
||||
(setq gds-breakpoint-cache
|
||||
(delq (assq bpdef gds-breakpoint-cache) gds-breakpoint-cache)))
|
||||
;; Remove the overlay from its buffer.
|
||||
(delete-overlay o)
|
||||
;; If that was the last breakpoint in this buffer, remove this
|
||||
;; buffer from gds-breakpoint-buffers.
|
||||
(or gds-breakpoint-cache
|
||||
(setq gds-breakpoint-buffers
|
||||
(delq (current-buffer) gds-breakpoint-buffers)))
|
||||
;; Update the persistent breakpoints file.
|
||||
(gds-write-breakpoints-file))
|
||||
|
||||
(defun gds-breakpoint-at-point ()
|
||||
"Find and return the overlay for a breakpoint `at' the current
|
||||
cursor position. This is intended for use in other functions'
|
||||
interactive forms, so it intentionally uses the minibuffer in some
|
||||
situations."
|
||||
(let* ((region (gds-defun-name-region))
|
||||
(os (gds-union (gds-breakpoint-overlays-at (point))
|
||||
(and region
|
||||
(gds-breakpoint-overlays-at (car region))))))
|
||||
;; Switch depending whether we found 0, 1 or more overlays.
|
||||
(cond ((null os)
|
||||
;; None found: return nil.
|
||||
nil)
|
||||
((= (length os) 1)
|
||||
;; One found: return it.
|
||||
(car os))
|
||||
(t
|
||||
;; More than 1 found: ask the user to choose.
|
||||
(gds-user-selected-breakpoint os)))))
|
||||
|
||||
(defun gds-union (first second &rest others)
|
||||
(if others
|
||||
(gds-union first (apply 'gds-union second others))
|
||||
(progn
|
||||
(while first
|
||||
(or (memq (car first) second)
|
||||
(setq second (cons (car first) second)))
|
||||
(setq first (cdr first)))
|
||||
second)))
|
||||
|
||||
(defun gds-user-selected-breakpoint (os)
|
||||
"Ask the user to choose one of the given list of breakpoints, and
|
||||
return the one that they chose."
|
||||
(let ((table (mapcar
|
||||
(lambda (o)
|
||||
(cons (format "%S"
|
||||
(overlay-get o 'gds-breakpoint-definition))
|
||||
o))
|
||||
os)))
|
||||
(cdr (assoc (completing-read "Which breakpoint do you mean? "
|
||||
table nil t)
|
||||
table))))
|
||||
|
||||
(defun gds-describe-breakpoints ()
|
||||
"Describe all breakpoints and their programming status."
|
||||
(interactive)
|
||||
(with-current-buffer (get-buffer-create "*GDS Breakpoints*")
|
||||
(erase-buffer)
|
||||
(gds-fold-breakpoints (function gds-describe-breakpoint))
|
||||
(display-buffer (current-buffer))))
|
||||
|
||||
(defun gds-describe-breakpoint (bpnum bpdef)
|
||||
(insert (format "Breakpoint %d: %S\n" bpnum bpdef))
|
||||
(let ((bpproglist (cdr (assq bpnum gds-breakpoint-programming))))
|
||||
(mapcar (lambda (clientprog)
|
||||
(let ((client (car clientprog))
|
||||
(traplist (cdr clientprog)))
|
||||
(mapcar (lambda (trap)
|
||||
(insert (format " Client %d: %S\n" client trap)))
|
||||
traplist)))
|
||||
bpproglist)))
|
||||
|
||||
(defun gds-after-save-update-breakpoints ()
|
||||
"Function called when a buffer containing breakpoints is saved."
|
||||
(if (eq (derived-mode-class major-mode) 'scheme-mode)
|
||||
(save-restriction
|
||||
(widen)
|
||||
;; Get the current breakpoint overlays.
|
||||
(let ((os (overlays-in (point-min) (point-max)))
|
||||
(cache (copy-sequence gds-breakpoint-cache)))
|
||||
;; Identify any overlays that have disappeared by comparing
|
||||
;; against this buffer's definition cache, and
|
||||
;; simultaneously rebuild the cache to reflect the current
|
||||
;; set of overlays.
|
||||
(setq gds-breakpoint-cache nil)
|
||||
(while os
|
||||
(let* ((o (car os))
|
||||
(bpdef (overlay-get o 'gds-breakpoint-definition))
|
||||
(bpnum (overlay-get o 'gds-breakpoint-number)))
|
||||
(if bpdef
|
||||
;; o and bpdef describe a current breakpoint.
|
||||
(progn
|
||||
;; Remove this breakpoint from the old cache list,
|
||||
;; so we don't think it got lost.
|
||||
(setq cache (delq (assq bpdef cache) cache))
|
||||
;; Check whether this breakpoint's location has
|
||||
;; moved. If it has, update the breakpoint
|
||||
;; definition and the associated client.
|
||||
(let ((lcnow (gds-line-and-column (overlay-start o))))
|
||||
(if (equal lcnow (gds-bpdef:lc bpdef))
|
||||
nil ; Breakpoint hasn't moved.
|
||||
(gds-bpdef:setlc bpdef lcnow)
|
||||
(if gds-client
|
||||
(gds-send-breakpoint-to-client bpnum bpdef))))
|
||||
;; Add this breakpoint to the new cache list.
|
||||
(setq gds-breakpoint-cache
|
||||
(cons (list bpdef bpnum) gds-breakpoint-cache)))))
|
||||
(setq os (cdr os)))
|
||||
;; cache now holds the set of lost breakpoints. If we are
|
||||
;; supposed to explicitly delete these from the associated
|
||||
;; client, do that now.
|
||||
(if (and gds-delete-lost-breakpoints gds-client)
|
||||
(while cache
|
||||
(gds-send (format "delete-breakpoint %d" (cadr (car cache)))
|
||||
gds-client)
|
||||
(setq cache (cdr cache)))))
|
||||
;; If this buffer now has no breakpoints, remove it from
|
||||
;; gds-breakpoint-buffers.
|
||||
(or gds-breakpoint-cache
|
||||
(setq gds-breakpoint-buffers
|
||||
(delq (current-buffer) gds-breakpoint-buffers)))
|
||||
;; Update the persistent breakpoints file.
|
||||
(gds-write-breakpoints-file))))
|
||||
|
||||
(add-hook 'after-save-hook (function gds-after-save-update-breakpoints))
|
||||
|
||||
;;;; Dispatcher for non-debug protocol.
|
||||
|
||||
(defun gds-nondebug-protocol (client proc args)
|
||||
|
|
@ -977,28 +500,6 @@ return the one that they chose."
|
|||
(eq proc 'completion-result)
|
||||
(setq gds-completion-results (or (car args) t)))
|
||||
|
||||
(;; (breakpoint NUM STATUS) - Breakpoint set.
|
||||
(eq proc 'breakpoint)
|
||||
(let* ((bpnum (car args))
|
||||
(traplist (cdr args))
|
||||
(bpentry (assq bpnum gds-breakpoint-programming)))
|
||||
(message "Breakpoint %d: %s" bpnum traplist)
|
||||
(if bpentry
|
||||
(let ((cliententry (assq client (cdr bpentry))))
|
||||
(if cliententry
|
||||
(setcdr cliententry traplist)
|
||||
(setcdr bpentry
|
||||
(cons (cons client traplist) (cdr bpentry)))))
|
||||
(setq gds-breakpoint-programming
|
||||
(cons (list bpnum (cons client traplist))
|
||||
gds-breakpoint-programming)))))
|
||||
|
||||
(;; (get-breakpoints) - Set all breakpoints.
|
||||
(eq proc 'get-breakpoints)
|
||||
(let ((gds-client client))
|
||||
(gds-fold-breakpoints (function gds-send-breakpoint-to-client)))
|
||||
(gds-send "continue" client))
|
||||
|
||||
(;; (note ...) - For debugging only.
|
||||
(eq proc 'note))
|
||||
|
||||
|
|
@ -1025,28 +526,6 @@ return the one that they chose."
|
|||
(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)
|
||||
|
||||
(define-prefix-command 'gds-breakpoint-map)
|
||||
(define-key scheme-mode-map "\C-c\C-b" 'gds-breakpoint-map)
|
||||
(define-key gds-breakpoint-map " " 'gds-set-breakpoint)
|
||||
(define-key gds-breakpoint-map "d"
|
||||
(function (lambda ()
|
||||
(interactive)
|
||||
(let ((gds-default-breakpoint-type 'debug))
|
||||
(gds-set-breakpoint)))))
|
||||
(define-key gds-breakpoint-map "t"
|
||||
(function (lambda ()
|
||||
(interactive)
|
||||
(let ((gds-default-breakpoint-type 'trace))
|
||||
(gds-set-breakpoint)))))
|
||||
(define-key gds-breakpoint-map "T"
|
||||
(function (lambda ()
|
||||
(interactive)
|
||||
(let ((gds-default-breakpoint-type 'trace-subtree))
|
||||
(gds-set-breakpoint)))))
|
||||
(define-key gds-breakpoint-map [backspace] 'gds-delete-breakpoints)
|
||||
(define-key gds-breakpoint-map "?" 'gds-describe-breakpoints)
|
||||
|
||||
;;;; The end!
|
||||
|
||||
|
|
|
|||
12
emacs/gds.el
12
emacs/gds.el
|
|
@ -622,18 +622,6 @@ you would add an element to this alist to transform
|
|||
(not gds-debug-server))
|
||||
(gds-run-debug-server))
|
||||
|
||||
;; Things to do only when this file is loaded for the first time.
|
||||
;; (And not, for example, when code is reevaluated by eval-buffer.)
|
||||
(defvar gds-scheme-first-load t)
|
||||
(if gds-scheme-first-load
|
||||
(progn
|
||||
;; Read the persistent breakpoints file, if configured.
|
||||
(if gds-breakpoints-file-name
|
||||
(gds-read-breakpoints-file))
|
||||
;; Note that first time load is complete.
|
||||
(setq gds-scheme-first-load nil)))
|
||||
|
||||
|
||||
;;;; The end!
|
||||
|
||||
(provide 'gds)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#!/bin/sh
|
||||
|
||||
# Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc.
|
||||
# Copyright (C) 2001, 2003, 2006, 2008 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
|
||||
|
|
@ -43,7 +43,8 @@ EOF
|
|||
}
|
||||
|
||||
prefix="@prefix@"
|
||||
pkgdatadir="@datarootdir@/@PACKAGE@"
|
||||
datarootdir="@datarootdir@"
|
||||
pkgdatadir="@datadir@/@PACKAGE@"
|
||||
guileversion="@GUILE_EFFECTIVE_VERSION@"
|
||||
default_scriptsdir=$pkgdatadir/$guileversion/scripts
|
||||
|
||||
|
|
|
|||
111
lib/Makefile.am
111
lib/Makefile.am
|
|
@ -9,10 +9,11 @@
|
|||
# the same distribution terms as the rest of that program.
|
||||
#
|
||||
# Generated by gnulib-tool.
|
||||
# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl alloca autobuild count-one-bits extensions strcase strftime
|
||||
# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl alloca autobuild count-one-bits extensions full-read full-write strcase strftime
|
||||
|
||||
AUTOMAKE_OPTIONS = 1.5 gnits
|
||||
|
||||
SUBDIRS =
|
||||
noinst_HEADERS =
|
||||
noinst_LIBRARIES =
|
||||
noinst_LTLIBRARIES =
|
||||
|
|
@ -70,6 +71,18 @@ EXTRA_DIST += count-one-bits.h
|
|||
|
||||
## end gnulib module count-one-bits
|
||||
|
||||
## begin gnulib module full-read
|
||||
|
||||
libgnu_la_SOURCES += full-read.h full-read.c
|
||||
|
||||
## end gnulib module full-read
|
||||
|
||||
## begin gnulib module full-write
|
||||
|
||||
libgnu_la_SOURCES += full-write.h full-write.c
|
||||
|
||||
## end gnulib module full-write
|
||||
|
||||
## begin gnulib module link-warning
|
||||
|
||||
LINK_WARNING_H=$(top_srcdir)/build-aux/link-warning.h
|
||||
|
|
@ -78,6 +91,24 @@ EXTRA_DIST += $(top_srcdir)/build-aux/link-warning.h
|
|||
|
||||
## end gnulib module link-warning
|
||||
|
||||
## begin gnulib module safe-read
|
||||
|
||||
|
||||
EXTRA_DIST += safe-read.c safe-read.h
|
||||
|
||||
EXTRA_libgnu_la_SOURCES += safe-read.c
|
||||
|
||||
## end gnulib module safe-read
|
||||
|
||||
## begin gnulib module safe-write
|
||||
|
||||
|
||||
EXTRA_DIST += safe-write.c safe-write.h
|
||||
|
||||
EXTRA_libgnu_la_SOURCES += safe-write.c
|
||||
|
||||
## end gnulib module safe-write
|
||||
|
||||
## begin gnulib module stdbool
|
||||
|
||||
BUILT_SOURCES += $(STDBOOL_H)
|
||||
|
|
@ -174,6 +205,74 @@ EXTRA_libgnu_la_SOURCES += time_r.c
|
|||
|
||||
## end gnulib module time_r
|
||||
|
||||
## begin gnulib module unistd
|
||||
|
||||
BUILT_SOURCES += unistd.h
|
||||
|
||||
# We need the following in order to create an empty placeholder for
|
||||
# <unistd.h> when the system doesn't have one.
|
||||
unistd.h: unistd.in.h
|
||||
rm -f $@-t $@
|
||||
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
|
||||
sed -e 's|@''HAVE_UNISTD_H''@|$(HAVE_UNISTD_H)|g' \
|
||||
-e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
|
||||
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
|
||||
-e 's|@''NEXT_UNISTD_H''@|$(NEXT_UNISTD_H)|g' \
|
||||
-e 's|@''GNULIB_CHOWN''@|$(GNULIB_CHOWN)|g' \
|
||||
-e 's|@''GNULIB_CLOSE''@|$(GNULIB_CLOSE)|g' \
|
||||
-e 's|@''GNULIB_DUP2''@|$(GNULIB_DUP2)|g' \
|
||||
-e 's|@''GNULIB_ENVIRON''@|$(GNULIB_ENVIRON)|g' \
|
||||
-e 's|@''GNULIB_EUIDACCESS''@|$(GNULIB_EUIDACCESS)|g' \
|
||||
-e 's|@''GNULIB_FCHDIR''@|$(GNULIB_FCHDIR)|g' \
|
||||
-e 's|@''GNULIB_FSYNC''@|$(GNULIB_FSYNC)|g' \
|
||||
-e 's|@''GNULIB_FTRUNCATE''@|$(GNULIB_FTRUNCATE)|g' \
|
||||
-e 's|@''GNULIB_GETCWD''@|$(GNULIB_GETCWD)|g' \
|
||||
-e 's|@''GNULIB_GETDOMAINNAME''@|$(GNULIB_GETDOMAINNAME)|g' \
|
||||
-e 's|@''GNULIB_GETDTABLESIZE''@|$(GNULIB_GETDTABLESIZE)|g' \
|
||||
-e 's|@''GNULIB_GETHOSTNAME''@|$(GNULIB_GETHOSTNAME)|g' \
|
||||
-e 's|@''GNULIB_GETLOGIN_R''@|$(GNULIB_GETLOGIN_R)|g' \
|
||||
-e 's|@''GNULIB_GETPAGESIZE''@|$(GNULIB_GETPAGESIZE)|g' \
|
||||
-e 's|@''GNULIB_GETUSERSHELL''@|$(GNULIB_GETUSERSHELL)|g' \
|
||||
-e 's|@''GNULIB_LCHOWN''@|$(GNULIB_LCHOWN)|g' \
|
||||
-e 's|@''GNULIB_LSEEK''@|$(GNULIB_LSEEK)|g' \
|
||||
-e 's|@''GNULIB_READLINK''@|$(GNULIB_READLINK)|g' \
|
||||
-e 's|@''GNULIB_SLEEP''@|$(GNULIB_SLEEP)|g' \
|
||||
-e 's|@''GNULIB_UNISTD_H_SIGPIPE''@|$(GNULIB_UNISTD_H_SIGPIPE)|g' \
|
||||
-e 's|@''GNULIB_WRITE''@|$(GNULIB_WRITE)|g' \
|
||||
-e 's|@''HAVE_DUP2''@|$(HAVE_DUP2)|g' \
|
||||
-e 's|@''HAVE_EUIDACCESS''@|$(HAVE_EUIDACCESS)|g' \
|
||||
-e 's|@''HAVE_FSYNC''@|$(HAVE_FSYNC)|g' \
|
||||
-e 's|@''HAVE_FTRUNCATE''@|$(HAVE_FTRUNCATE)|g' \
|
||||
-e 's|@''HAVE_GETDOMAINNAME''@|$(HAVE_GETDOMAINNAME)|g' \
|
||||
-e 's|@''HAVE_GETDTABLESIZE''@|$(HAVE_GETDTABLESIZE)|g' \
|
||||
-e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \
|
||||
-e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \
|
||||
-e 's|@''HAVE_GETUSERSHELL''@|$(HAVE_GETUSERSHELL)|g' \
|
||||
-e 's|@''HAVE_READLINK''@|$(HAVE_READLINK)|g' \
|
||||
-e 's|@''HAVE_SLEEP''@|$(HAVE_SLEEP)|g' \
|
||||
-e 's|@''HAVE_DECL_ENVIRON''@|$(HAVE_DECL_ENVIRON)|g' \
|
||||
-e 's|@''HAVE_DECL_GETLOGIN_R''@|$(HAVE_DECL_GETLOGIN_R)|g' \
|
||||
-e 's|@''HAVE_OS_H''@|$(HAVE_OS_H)|g' \
|
||||
-e 's|@''HAVE_SYS_PARAM_H''@|$(HAVE_SYS_PARAM_H)|g' \
|
||||
-e 's|@''REPLACE_CHOWN''@|$(REPLACE_CHOWN)|g' \
|
||||
-e 's|@''REPLACE_CLOSE''@|$(REPLACE_CLOSE)|g' \
|
||||
-e 's|@''REPLACE_FCHDIR''@|$(REPLACE_FCHDIR)|g' \
|
||||
-e 's|@''REPLACE_GETCWD''@|$(REPLACE_GETCWD)|g' \
|
||||
-e 's|@''REPLACE_GETPAGESIZE''@|$(REPLACE_GETPAGESIZE)|g' \
|
||||
-e 's|@''REPLACE_LCHOWN''@|$(REPLACE_LCHOWN)|g' \
|
||||
-e 's|@''REPLACE_LSEEK''@|$(REPLACE_LSEEK)|g' \
|
||||
-e 's|@''REPLACE_WRITE''@|$(REPLACE_WRITE)|g' \
|
||||
-e 's|@''UNISTD_H_HAVE_WINSOCK2_H''@|$(UNISTD_H_HAVE_WINSOCK2_H)|g' \
|
||||
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
|
||||
< $(srcdir)/unistd.in.h; \
|
||||
} > $@-t
|
||||
mv $@-t $@
|
||||
MOSTLYCLEANFILES += unistd.h unistd.h-t
|
||||
|
||||
EXTRA_DIST += unistd.in.h
|
||||
|
||||
## end gnulib module unistd
|
||||
|
||||
## begin gnulib module verify
|
||||
|
||||
libgnu_la_SOURCES += verify.h
|
||||
|
|
@ -194,6 +293,7 @@ wchar.h: wchar.in.h
|
|||
-e 's|@''NEXT_WCHAR_H''@|$(NEXT_WCHAR_H)|g' \
|
||||
-e 's/@''HAVE_WCHAR_H''@/$(HAVE_WCHAR_H)/g' \
|
||||
-e 's|@''GNULIB_WCWIDTH''@|$(GNULIB_WCWIDTH)|g' \
|
||||
-e 's/@''HAVE_WINT_T''@/$(HAVE_WINT_T)/g' \
|
||||
-e 's|@''HAVE_DECL_WCWIDTH''@|$(HAVE_DECL_WCWIDTH)|g' \
|
||||
-e 's|@''REPLACE_WCWIDTH''@|$(REPLACE_WCWIDTH)|g' \
|
||||
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
|
||||
|
|
@ -206,11 +306,14 @@ EXTRA_DIST += wchar.in.h
|
|||
|
||||
## end gnulib module wchar
|
||||
|
||||
## begin gnulib module dummy
|
||||
## begin gnulib module write
|
||||
|
||||
libgnu_la_SOURCES += dummy.c
|
||||
|
||||
## end gnulib module dummy
|
||||
EXTRA_DIST += write.c
|
||||
|
||||
EXTRA_libgnu_la_SOURCES += write.c
|
||||
|
||||
## end gnulib module write
|
||||
|
||||
|
||||
mostlyclean-local: mostlyclean-generic
|
||||
|
|
|
|||
42
lib/dummy.c
42
lib/dummy.c
|
|
@ -1,42 +0,0 @@
|
|||
/* A dummy file, to prevent empty libraries from breaking builds.
|
||||
Copyright (C) 2004, 2007 Free Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
/* Some systems, reportedly OpenBSD and Mac OS X, refuse to create
|
||||
libraries without any object files. You might get an error like:
|
||||
|
||||
> ar cru .libs/libgl.a
|
||||
> ar: no archive members specified
|
||||
|
||||
Compiling this file, and adding its object file to the library, will
|
||||
prevent the library from being empty. */
|
||||
|
||||
/* Some systems, such as Solaris with cc 5.0, refuse to work with libraries
|
||||
that don't export any symbol. You might get an error like:
|
||||
|
||||
> cc ... libgnu.a
|
||||
> ild: (bad file) garbled symbol table in archive ../gllib/libgnu.a
|
||||
|
||||
Compiling this file, and adding its object file to the library, will
|
||||
prevent the library from exporting no symbols. */
|
||||
|
||||
#ifdef __sun
|
||||
/* This declaration ensures that the library will export at least 1 symbol. */
|
||||
int gl_dummy_symbol;
|
||||
#else
|
||||
/* This declaration is solely to ensure that after preprocessing
|
||||
this file is never empty. */
|
||||
typedef int dummy;
|
||||
#endif
|
||||
18
lib/full-read.c
Normal file
18
lib/full-read.c
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
/* An interface to read that retries after partial reads and interrupts.
|
||||
Copyright (C) 2002, 2003 Free Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#define FULL_READ
|
||||
#include "full-write.c"
|
||||
24
lib/full-read.h
Normal file
24
lib/full-read.h
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
/* An interface to read() that reads all it is asked to read.
|
||||
|
||||
Copyright (C) 2002 Free Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program; if not, read to the Free Software Foundation,
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include <stddef.h>
|
||||
|
||||
/* Read COUNT bytes at BUF to descriptor FD, retrying if interrupted
|
||||
or if partial reads occur. Return the number of bytes successfully
|
||||
read, setting errno if that is less than COUNT. errno = 0 means EOF. */
|
||||
extern size_t full_read (int fd, void *buf, size_t count);
|
||||
80
lib/full-write.c
Normal file
80
lib/full-write.c
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
/* An interface to read and write that retries (if necessary) until complete.
|
||||
|
||||
Copyright (C) 1993, 1994, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
|
||||
2004, 2005, 2006 Free Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include <config.h>
|
||||
|
||||
/* Specification. */
|
||||
#ifdef FULL_READ
|
||||
# include "full-read.h"
|
||||
#else
|
||||
# include "full-write.h"
|
||||
#endif
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#ifdef FULL_READ
|
||||
# include "safe-read.h"
|
||||
# define safe_rw safe_read
|
||||
# define full_rw full_read
|
||||
# undef const
|
||||
# define const /* empty */
|
||||
#else
|
||||
# include "safe-write.h"
|
||||
# define safe_rw safe_write
|
||||
# define full_rw full_write
|
||||
#endif
|
||||
|
||||
#ifdef FULL_READ
|
||||
/* Set errno to zero upon EOF. */
|
||||
# define ZERO_BYTE_TRANSFER_ERRNO 0
|
||||
#else
|
||||
/* Some buggy drivers return 0 when one tries to write beyond
|
||||
a device's end. (Example: Linux 1.2.13 on /dev/fd0.)
|
||||
Set errno to ENOSPC so they get a sensible diagnostic. */
|
||||
# define ZERO_BYTE_TRANSFER_ERRNO ENOSPC
|
||||
#endif
|
||||
|
||||
/* Write(read) COUNT bytes at BUF to(from) descriptor FD, retrying if
|
||||
interrupted or if a partial write(read) occurs. Return the number
|
||||
of bytes transferred.
|
||||
When writing, set errno if fewer than COUNT bytes are written.
|
||||
When reading, if fewer than COUNT bytes are read, you must examine
|
||||
errno to distinguish failure from EOF (errno == 0). */
|
||||
size_t
|
||||
full_rw (int fd, const void *buf, size_t count)
|
||||
{
|
||||
size_t total = 0;
|
||||
const char *ptr = (const char *) buf;
|
||||
|
||||
while (count > 0)
|
||||
{
|
||||
size_t n_rw = safe_rw (fd, ptr, count);
|
||||
if (n_rw == (size_t) -1)
|
||||
break;
|
||||
if (n_rw == 0)
|
||||
{
|
||||
errno = ZERO_BYTE_TRANSFER_ERRNO;
|
||||
break;
|
||||
}
|
||||
total += n_rw;
|
||||
ptr += n_rw;
|
||||
count -= n_rw;
|
||||
}
|
||||
|
||||
return total;
|
||||
}
|
||||
34
lib/full-write.h
Normal file
34
lib/full-write.h
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
/* An interface to write() that writes all it is asked to write.
|
||||
|
||||
Copyright (C) 2002-2003 Free Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include <stddef.h>
|
||||
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
|
||||
/* Write COUNT bytes at BUF to descriptor FD, retrying if interrupted
|
||||
or if partial writes occur. Return the number of bytes successfully
|
||||
written, setting errno if that is less than COUNT. */
|
||||
extern size_t full_write (int fd, const void *buf, size_t count);
|
||||
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
77
lib/safe-read.c
Normal file
77
lib/safe-read.c
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
/* An interface to read and write that retries after interrupts.
|
||||
|
||||
Copyright (C) 1993, 1994, 1998, 2002, 2003, 2004, 2005, 2006 Free
|
||||
Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include <config.h>
|
||||
|
||||
/* Specification. */
|
||||
#ifdef SAFE_WRITE
|
||||
# include "safe-write.h"
|
||||
#else
|
||||
# include "safe-read.h"
|
||||
#endif
|
||||
|
||||
/* Get ssize_t. */
|
||||
#include <sys/types.h>
|
||||
#include <unistd.h>
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#ifdef EINTR
|
||||
# define IS_EINTR(x) ((x) == EINTR)
|
||||
#else
|
||||
# define IS_EINTR(x) 0
|
||||
#endif
|
||||
|
||||
#include <limits.h>
|
||||
|
||||
#ifdef SAFE_WRITE
|
||||
# define safe_rw safe_write
|
||||
# define rw write
|
||||
#else
|
||||
# define safe_rw safe_read
|
||||
# define rw read
|
||||
# undef const
|
||||
# define const /* empty */
|
||||
#endif
|
||||
|
||||
/* Read(write) up to COUNT bytes at BUF from(to) descriptor FD, retrying if
|
||||
interrupted. Return the actual number of bytes read(written), zero for EOF,
|
||||
or SAFE_READ_ERROR(SAFE_WRITE_ERROR) upon error. */
|
||||
size_t
|
||||
safe_rw (int fd, void const *buf, size_t count)
|
||||
{
|
||||
/* Work around a bug in Tru64 5.1. Attempting to read more than
|
||||
INT_MAX bytes fails with errno == EINVAL. See
|
||||
<http://lists.gnu.org/archive/html/bug-gnu-utils/2002-04/msg00010.html>.
|
||||
When decreasing COUNT, keep it block-aligned. */
|
||||
enum { BUGGY_READ_MAXIMUM = INT_MAX & ~8191 };
|
||||
|
||||
for (;;)
|
||||
{
|
||||
ssize_t result = rw (fd, buf, count);
|
||||
|
||||
if (0 <= result)
|
||||
return result;
|
||||
else if (IS_EINTR (errno))
|
||||
continue;
|
||||
else if (errno == EINVAL && BUGGY_READ_MAXIMUM < count)
|
||||
count = BUGGY_READ_MAXIMUM;
|
||||
else
|
||||
return result;
|
||||
}
|
||||
}
|
||||
34
lib/safe-read.h
Normal file
34
lib/safe-read.h
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
/* An interface to read() that retries after interrupts.
|
||||
Copyright (C) 2002, 2006 Free Software Foundation, Inc.
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Lesser General Public License as published by
|
||||
the Free Software Foundation; either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include <stddef.h>
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
|
||||
#define SAFE_READ_ERROR ((size_t) -1)
|
||||
|
||||
/* Read up to COUNT bytes at BUF from descriptor FD, retrying if interrupted.
|
||||
Return the actual number of bytes read, zero for EOF, or SAFE_READ_ERROR
|
||||
upon error. */
|
||||
extern size_t safe_read (int fd, void *buf, size_t count);
|
||||
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
18
lib/safe-write.c
Normal file
18
lib/safe-write.c
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
/* An interface to write that retries after interrupts.
|
||||
Copyright (C) 2002 Free Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#define SAFE_WRITE
|
||||
#include "safe-read.c"
|
||||
24
lib/safe-write.h
Normal file
24
lib/safe-write.h
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
/* An interface to write() that retries after interrupts.
|
||||
Copyright (C) 2002 Free Software Foundation, Inc.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include <stddef.h>
|
||||
|
||||
#define SAFE_WRITE_ERROR ((size_t) -1)
|
||||
|
||||
/* Write up to COUNT bytes at BUF to descriptor FD, retrying if interrupted.
|
||||
Return the actual number of bytes written, zero for EOF, or SAFE_WRITE_ERROR
|
||||
upon error. */
|
||||
extern size_t safe_write (int fd, const void *buf, size_t count);
|
||||
|
|
@ -18,7 +18,9 @@
|
|||
|
||||
#ifndef _GL_STRINGS_H
|
||||
|
||||
#if __GNUC__ >= 3
|
||||
@PRAGMA_SYSTEM_HEADER@
|
||||
#endif
|
||||
|
||||
/* The include_next requires a split double-inclusion guard. */
|
||||
#@INCLUDE_NEXT@ @NEXT_STRINGS_H@
|
||||
|
|
|
|||
|
|
@ -16,7 +16,9 @@
|
|||
along with this program; if not, write to the Free Software Foundation,
|
||||
Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
|
||||
|
||||
#if __GNUC__ >= 3
|
||||
@PRAGMA_SYSTEM_HEADER@
|
||||
#endif
|
||||
|
||||
/* Don't get in the way of glibc when it includes time.h merely to
|
||||
declare a few standard symbols, rather than to declare all the
|
||||
|
|
|
|||
553
lib/unistd.in.h
Normal file
553
lib/unistd.in.h
Normal file
|
|
@ -0,0 +1,553 @@
|
|||
/* Substitute for and wrapper around <unistd.h>.
|
||||
Copyright (C) 2003-2008 Free Software Foundation, Inc.
|
||||
|
||||
This program 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, or (at your option)
|
||||
any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program; if not, write to the Free Software Foundation,
|
||||
Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
|
||||
|
||||
#ifndef _GL_UNISTD_H
|
||||
|
||||
#if __GNUC__ >= 3
|
||||
@PRAGMA_SYSTEM_HEADER@
|
||||
#endif
|
||||
|
||||
/* The include_next requires a split double-inclusion guard. */
|
||||
#if @HAVE_UNISTD_H@
|
||||
# @INCLUDE_NEXT@ @NEXT_UNISTD_H@
|
||||
#endif
|
||||
|
||||
#ifndef _GL_UNISTD_H
|
||||
#define _GL_UNISTD_H
|
||||
|
||||
/* mingw doesn't define the SEEK_* macros in <unistd.h>. */
|
||||
#if !(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET)
|
||||
# include <stdio.h>
|
||||
#endif
|
||||
|
||||
/* mingw fails to declare _exit in <unistd.h>. */
|
||||
#include <stdlib.h>
|
||||
|
||||
#if @GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@
|
||||
/* Get ssize_t. */
|
||||
# include <sys/types.h>
|
||||
#endif
|
||||
|
||||
#if @GNULIB_GETHOSTNAME@
|
||||
/* Get all possible declarations of gethostname(). */
|
||||
# if @UNISTD_H_HAVE_WINSOCK2_H@
|
||||
# include <winsock2.h>
|
||||
# if !defined _GL_SYS_SOCKET_H
|
||||
# undef socket
|
||||
# define socket socket_used_without_including_sys_socket_h
|
||||
# undef connect
|
||||
# define connect connect_used_without_including_sys_socket_h
|
||||
# undef accept
|
||||
# define accept accept_used_without_including_sys_socket_h
|
||||
# undef bind
|
||||
# define bind bind_used_without_including_sys_socket_h
|
||||
# undef getpeername
|
||||
# define getpeername getpeername_used_without_including_sys_socket_h
|
||||
# undef getsockname
|
||||
# define getsockname getsockname_used_without_including_sys_socket_h
|
||||
# undef getsockopt
|
||||
# define getsockopt getsockopt_used_without_including_sys_socket_h
|
||||
# undef listen
|
||||
# define listen listen_used_without_including_sys_socket_h
|
||||
# undef recv
|
||||
# define recv recv_used_without_including_sys_socket_h
|
||||
# undef send
|
||||
# define send send_used_without_including_sys_socket_h
|
||||
# undef recvfrom
|
||||
# define recvfrom recvfrom_used_without_including_sys_socket_h
|
||||
# undef sendto
|
||||
# define sendto sendto_used_without_including_sys_socket_h
|
||||
# undef setsockopt
|
||||
# define setsockopt setsockopt_used_without_including_sys_socket_h
|
||||
# undef shutdown
|
||||
# define shutdown shutdown_used_without_including_sys_socket_h
|
||||
# endif
|
||||
# if !defined _GL_SYS_SELECT_H
|
||||
# undef select
|
||||
# define select select_used_without_including_sys_select_h
|
||||
# endif
|
||||
# endif
|
||||
#endif
|
||||
|
||||
/* The definition of GL_LINK_WARNING is copied here. */
|
||||
|
||||
|
||||
/* Declare overridden functions. */
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_CHOWN@
|
||||
# if @REPLACE_CHOWN@
|
||||
# ifndef REPLACE_CHOWN
|
||||
# define REPLACE_CHOWN 1
|
||||
# endif
|
||||
# if REPLACE_CHOWN
|
||||
/* Change the owner of FILE to UID (if UID is not -1) and the group of FILE
|
||||
to GID (if GID is not -1). Follow symbolic links.
|
||||
Return 0 if successful, otherwise -1 and errno set.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/chown.html>. */
|
||||
# define chown rpl_chown
|
||||
extern int chown (const char *file, uid_t uid, gid_t gid);
|
||||
# endif
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef chown
|
||||
# define chown(f,u,g) \
|
||||
(GL_LINK_WARNING ("chown fails to follow symlinks on some systems and " \
|
||||
"doesn't treat a uid or gid of -1 on some systems - " \
|
||||
"use gnulib module chown for portability"), \
|
||||
chown (f, u, g))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_CLOSE@
|
||||
# if @UNISTD_H_HAVE_WINSOCK2_H@
|
||||
/* Need a gnulib internal function. */
|
||||
# define HAVE__GL_CLOSE_FD_MAYBE_SOCKET 1
|
||||
# endif
|
||||
# if @REPLACE_CLOSE@
|
||||
/* Automatically included by modules that need a replacement for close. */
|
||||
# undef close
|
||||
# define close rpl_close
|
||||
extern int close (int);
|
||||
# endif
|
||||
#elif @UNISTD_H_HAVE_WINSOCK2_H@
|
||||
# undef close
|
||||
# define close close_used_without_requesting_gnulib_module_close
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef close
|
||||
# define close(f) \
|
||||
(GL_LINK_WARNING ("close does not portably work on sockets - " \
|
||||
"use gnulib module close for portability"), \
|
||||
close (f))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_DUP2@
|
||||
# if !@HAVE_DUP2@
|
||||
/* Copy the file descriptor OLDFD into file descriptor NEWFD. Do nothing if
|
||||
NEWFD = OLDFD, otherwise close NEWFD first if it is open.
|
||||
Return 0 if successful, otherwise -1 and errno set.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/dup2.html>. */
|
||||
extern int dup2 (int oldfd, int newfd);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef dup2
|
||||
# define dup2(o,n) \
|
||||
(GL_LINK_WARNING ("dup2 is unportable - " \
|
||||
"use gnulib module dup2 for portability"), \
|
||||
dup2 (o, n))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_ENVIRON@
|
||||
# if !@HAVE_DECL_ENVIRON@
|
||||
/* Set of environment variables and values. An array of strings of the form
|
||||
"VARIABLE=VALUE", terminated with a NULL. */
|
||||
# if defined __APPLE__ && defined __MACH__
|
||||
# include <crt_externs.h>
|
||||
# define environ (*_NSGetEnviron ())
|
||||
# else
|
||||
extern char **environ;
|
||||
# endif
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef environ
|
||||
# define environ \
|
||||
(GL_LINK_WARNING ("environ is unportable - " \
|
||||
"use gnulib module environ for portability"), \
|
||||
environ)
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_EUIDACCESS@
|
||||
# if !@HAVE_EUIDACCESS@
|
||||
/* Like access(), except that is uses the effective user id and group id of
|
||||
the current process. */
|
||||
extern int euidaccess (const char *filename, int mode);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef euidaccess
|
||||
# define euidaccess(f,m) \
|
||||
(GL_LINK_WARNING ("euidaccess is unportable - " \
|
||||
"use gnulib module euidaccess for portability"), \
|
||||
euidaccess (f, m))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_FCHDIR@
|
||||
# if @REPLACE_FCHDIR@
|
||||
|
||||
/* Change the process' current working directory to the directory on which
|
||||
the given file descriptor is open.
|
||||
Return 0 if successful, otherwise -1 and errno set.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/fchdir.html>. */
|
||||
extern int fchdir (int /*fd*/);
|
||||
|
||||
# define dup rpl_dup
|
||||
extern int dup (int);
|
||||
# define dup2 rpl_dup2
|
||||
extern int dup2 (int, int);
|
||||
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef fchdir
|
||||
# define fchdir(f) \
|
||||
(GL_LINK_WARNING ("fchdir is unportable - " \
|
||||
"use gnulib module fchdir for portability"), \
|
||||
fchdir (f))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_FSYNC@
|
||||
/* Synchronize changes to a file.
|
||||
Return 0 if successful, otherwise -1 and errno set.
|
||||
See POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/fsync.html>. */
|
||||
# if !@HAVE_FSYNC@
|
||||
extern int fsync (int fd);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef fsync
|
||||
# define fsync(fd) \
|
||||
(GL_LINK_WARNING ("fsync is unportable - " \
|
||||
"use gnulib module fsync for portability"), \
|
||||
fsync (fd))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_FTRUNCATE@
|
||||
# if !@HAVE_FTRUNCATE@
|
||||
/* Change the size of the file to which FD is opened to become equal to LENGTH.
|
||||
Return 0 if successful, otherwise -1 and errno set.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/ftruncate.html>. */
|
||||
extern int ftruncate (int fd, off_t length);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef ftruncate
|
||||
# define ftruncate(f,l) \
|
||||
(GL_LINK_WARNING ("ftruncate is unportable - " \
|
||||
"use gnulib module ftruncate for portability"), \
|
||||
ftruncate (f, l))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_GETCWD@
|
||||
/* Include the headers that might declare getcwd so that they will not
|
||||
cause confusion if included after this file. */
|
||||
# include <stdlib.h>
|
||||
# if @REPLACE_GETCWD@
|
||||
/* Get the name of the current working directory, and put it in SIZE bytes
|
||||
of BUF.
|
||||
Return BUF if successful, or NULL if the directory couldn't be determined
|
||||
or SIZE was too small.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/getcwd.html>.
|
||||
Additionally, the gnulib module 'getcwd' guarantees the following GNU
|
||||
extension: If BUF is NULL, an array is allocated with 'malloc'; the array
|
||||
is SIZE bytes long, unless SIZE == 0, in which case it is as big as
|
||||
necessary. */
|
||||
# define getcwd rpl_getcwd
|
||||
extern char * getcwd (char *buf, size_t size);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef getcwd
|
||||
# define getcwd(b,s) \
|
||||
(GL_LINK_WARNING ("getcwd is unportable - " \
|
||||
"use gnulib module getcwd for portability"), \
|
||||
getcwd (b, s))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_GETDOMAINNAME@
|
||||
/* Return the NIS domain name of the machine.
|
||||
WARNING! The NIS domain name is unrelated to the fully qualified host name
|
||||
of the machine. It is also unrelated to email addresses.
|
||||
WARNING! The NIS domain name is usually the empty string or "(none)" when
|
||||
not using NIS.
|
||||
|
||||
Put up to LEN bytes of the NIS domain name into NAME.
|
||||
Null terminate it if the name is shorter than LEN.
|
||||
If the NIS domain name is longer than LEN, set errno = EINVAL and return -1.
|
||||
Return 0 if successful, otherwise set errno and return -1. */
|
||||
# if !@HAVE_GETDOMAINNAME@
|
||||
extern int getdomainname(char *name, size_t len);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef getdomainname
|
||||
# define getdomainname(n,l) \
|
||||
(GL_LINK_WARNING ("getdomainname is unportable - " \
|
||||
"use gnulib module getdomainname for portability"), \
|
||||
getdomainname (n, l))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_GETDTABLESIZE@
|
||||
# if !@HAVE_GETDTABLESIZE@
|
||||
/* Return the maximum number of file descriptors in the current process. */
|
||||
extern int getdtablesize (void);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef getdtablesize
|
||||
# define getdtablesize() \
|
||||
(GL_LINK_WARNING ("getdtablesize is unportable - " \
|
||||
"use gnulib module getdtablesize for portability"), \
|
||||
getdtablesize ())
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_GETHOSTNAME@
|
||||
/* Return the standard host name of the machine.
|
||||
WARNING! The host name may or may not be fully qualified.
|
||||
|
||||
Put up to LEN bytes of the host name into NAME.
|
||||
Null terminate it if the name is shorter than LEN.
|
||||
If the host name is longer than LEN, set errno = EINVAL and return -1.
|
||||
Return 0 if successful, otherwise set errno and return -1. */
|
||||
# if @UNISTD_H_HAVE_WINSOCK2_H@
|
||||
# undef gethostname
|
||||
# define gethostname rpl_gethostname
|
||||
# endif
|
||||
# if @UNISTD_H_HAVE_WINSOCK2_H@ || !@HAVE_GETHOSTNAME@
|
||||
extern int gethostname(char *name, size_t len);
|
||||
# endif
|
||||
#elif @UNISTD_H_HAVE_WINSOCK2_H@
|
||||
# undef gethostname
|
||||
# define gethostname gethostname_used_without_requesting_gnulib_module_gethostname
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef gethostname
|
||||
# define gethostname(n,l) \
|
||||
(GL_LINK_WARNING ("gethostname is unportable - " \
|
||||
"use gnulib module gethostname for portability"), \
|
||||
gethostname (n, l))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_GETLOGIN_R@
|
||||
/* Copies the user's login name to NAME.
|
||||
The array pointed to by NAME has room for SIZE bytes.
|
||||
|
||||
Returns 0 if successful. Upon error, an error number is returned, or -1 in
|
||||
the case that the login name cannot be found but no specific error is
|
||||
provided (this case is hopefully rare but is left open by the POSIX spec).
|
||||
|
||||
See <http://www.opengroup.org/susv3xsh/getlogin.html>.
|
||||
*/
|
||||
# if !@HAVE_DECL_GETLOGIN_R@
|
||||
# include <stddef.h>
|
||||
extern int getlogin_r (char *name, size_t size);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef getlogin_r
|
||||
# define getlogin_r(n,s) \
|
||||
(GL_LINK_WARNING ("getlogin_r is unportable - " \
|
||||
"use gnulib module getlogin_r for portability"), \
|
||||
getlogin_r (n, s))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_GETPAGESIZE@
|
||||
# if @REPLACE_GETPAGESIZE@
|
||||
# define getpagesize rpl_getpagesize
|
||||
extern int getpagesize (void);
|
||||
# elif !@HAVE_GETPAGESIZE@
|
||||
/* This is for POSIX systems. */
|
||||
# if !defined getpagesize && defined _SC_PAGESIZE
|
||||
# if ! (defined __VMS && __VMS_VER < 70000000)
|
||||
# define getpagesize() sysconf (_SC_PAGESIZE)
|
||||
# endif
|
||||
# endif
|
||||
/* This is for older VMS. */
|
||||
# if !defined getpagesize && defined __VMS
|
||||
# ifdef __ALPHA
|
||||
# define getpagesize() 8192
|
||||
# else
|
||||
# define getpagesize() 512
|
||||
# endif
|
||||
# endif
|
||||
/* This is for BeOS. */
|
||||
# if !defined getpagesize && @HAVE_OS_H@
|
||||
# include <OS.h>
|
||||
# if defined B_PAGE_SIZE
|
||||
# define getpagesize() B_PAGE_SIZE
|
||||
# endif
|
||||
# endif
|
||||
/* This is for AmigaOS4.0. */
|
||||
# if !defined getpagesize && defined __amigaos4__
|
||||
# define getpagesize() 2048
|
||||
# endif
|
||||
/* This is for older Unix systems. */
|
||||
# if !defined getpagesize && @HAVE_SYS_PARAM_H@
|
||||
# include <sys/param.h>
|
||||
# ifdef EXEC_PAGESIZE
|
||||
# define getpagesize() EXEC_PAGESIZE
|
||||
# else
|
||||
# ifdef NBPG
|
||||
# ifndef CLSIZE
|
||||
# define CLSIZE 1
|
||||
# endif
|
||||
# define getpagesize() (NBPG * CLSIZE)
|
||||
# else
|
||||
# ifdef NBPC
|
||||
# define getpagesize() NBPC
|
||||
# endif
|
||||
# endif
|
||||
# endif
|
||||
# endif
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef getpagesize
|
||||
# define getpagesize() \
|
||||
(GL_LINK_WARNING ("getpagesize is unportable - " \
|
||||
"use gnulib module getpagesize for portability"), \
|
||||
getpagesize ())
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_GETUSERSHELL@
|
||||
# if !@HAVE_GETUSERSHELL@
|
||||
/* Return the next valid login shell on the system, or NULL when the end of
|
||||
the list has been reached. */
|
||||
extern char *getusershell (void);
|
||||
/* Rewind to pointer that is advanced at each getusershell() call. */
|
||||
extern void setusershell (void);
|
||||
/* Free the pointer that is advanced at each getusershell() call and
|
||||
associated resources. */
|
||||
extern void endusershell (void);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef getusershell
|
||||
# define getusershell() \
|
||||
(GL_LINK_WARNING ("getusershell is unportable - " \
|
||||
"use gnulib module getusershell for portability"), \
|
||||
getusershell ())
|
||||
# undef setusershell
|
||||
# define setusershell() \
|
||||
(GL_LINK_WARNING ("setusershell is unportable - " \
|
||||
"use gnulib module getusershell for portability"), \
|
||||
setusershell ())
|
||||
# undef endusershell
|
||||
# define endusershell() \
|
||||
(GL_LINK_WARNING ("endusershell is unportable - " \
|
||||
"use gnulib module getusershell for portability"), \
|
||||
endusershell ())
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_LCHOWN@
|
||||
# if @REPLACE_LCHOWN@
|
||||
/* Change the owner of FILE to UID (if UID is not -1) and the group of FILE
|
||||
to GID (if GID is not -1). Do not follow symbolic links.
|
||||
Return 0 if successful, otherwise -1 and errno set.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/lchown.html>. */
|
||||
# define lchown rpl_lchown
|
||||
extern int lchown (char const *file, uid_t owner, gid_t group);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef lchown
|
||||
# define lchown(f,u,g) \
|
||||
(GL_LINK_WARNING ("lchown is unportable to pre-POSIX.1-2001 " \
|
||||
"systems - use gnulib module lchown for portability"), \
|
||||
lchown (f, u, g))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_LSEEK@
|
||||
# if @REPLACE_LSEEK@
|
||||
/* Set the offset of FD relative to SEEK_SET, SEEK_CUR, or SEEK_END.
|
||||
Return the new offset if successful, otherwise -1 and errno set.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/lseek.html>. */
|
||||
# define lseek rpl_lseek
|
||||
extern off_t lseek (int fd, off_t offset, int whence);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef lseek
|
||||
# define lseek(f,o,w) \
|
||||
(GL_LINK_WARNING ("lseek does not fail with ESPIPE on pipes on some " \
|
||||
"systems - use gnulib module lseek for portability"), \
|
||||
lseek (f, o, w))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_READLINK@
|
||||
/* Read the contents of the symbolic link FILE and place the first BUFSIZE
|
||||
bytes of it into BUF. Return the number of bytes placed into BUF if
|
||||
successful, otherwise -1 and errno set.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/readlink.html>. */
|
||||
# if !@HAVE_READLINK@
|
||||
# include <stddef.h>
|
||||
extern int readlink (const char *file, char *buf, size_t bufsize);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef readlink
|
||||
# define readlink(f,b,s) \
|
||||
(GL_LINK_WARNING ("readlink is unportable - " \
|
||||
"use gnulib module readlink for portability"), \
|
||||
readlink (f, b, s))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_SLEEP@
|
||||
/* Pause the execution of the current thread for N seconds.
|
||||
Returns the number of seconds left to sleep.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/sleep.html>. */
|
||||
# if !@HAVE_SLEEP@
|
||||
extern unsigned int sleep (unsigned int n);
|
||||
# endif
|
||||
#elif defined GNULIB_POSIXCHECK
|
||||
# undef sleep
|
||||
# define sleep(n) \
|
||||
(GL_LINK_WARNING ("sleep is unportable - " \
|
||||
"use gnulib module sleep for portability"), \
|
||||
sleep (n))
|
||||
#endif
|
||||
|
||||
|
||||
#if @GNULIB_WRITE@ && @REPLACE_WRITE@ && @GNULIB_UNISTD_H_SIGPIPE@
|
||||
/* Write up to COUNT bytes starting at BUF to file descriptor FD.
|
||||
See the POSIX:2001 specification
|
||||
<http://www.opengroup.org/susv3xsh/write.html>. */
|
||||
# undef write
|
||||
# define write rpl_write
|
||||
extern ssize_t write (int fd, const void *buf, size_t count);
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef FCHDIR_REPLACEMENT
|
||||
/* gnulib internal function. */
|
||||
extern void _gl_unregister_fd (int fd);
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
|
||||
#endif /* _GL_UNISTD_H */
|
||||
#endif /* _GL_UNISTD_H */
|
||||
|
|
@ -26,7 +26,9 @@
|
|||
* the declaration of wcwidth().
|
||||
*/
|
||||
|
||||
#if __GNUC__ >= 3
|
||||
@PRAGMA_SYSTEM_HEADER@
|
||||
#endif
|
||||
|
||||
#ifdef __need_mbstate_t
|
||||
/* Special invocation convention inside uClibc header files. */
|
||||
|
|
@ -63,6 +65,12 @@ extern "C" {
|
|||
#endif
|
||||
|
||||
|
||||
/* Define wint_t. (Also done in wctype.in.h.) */
|
||||
#if !@HAVE_WINT_T@ && !defined wint_t
|
||||
# define wint_t int
|
||||
#endif
|
||||
|
||||
|
||||
/* Return the number of screen columns needed for WC. */
|
||||
#if @GNULIB_WCWIDTH@
|
||||
# if @REPLACE_WCWIDTH@
|
||||
|
|
|
|||
62
lib/write.c
Normal file
62
lib/write.c
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
/* POSIX compatible write() function.
|
||||
Copyright (C) 2008 Free Software Foundation, Inc.
|
||||
Written by Bruno Haible <bruno@clisp.org>, 2008.
|
||||
|
||||
This program 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include <config.h>
|
||||
|
||||
/* Specification. */
|
||||
#include <unistd.h>
|
||||
|
||||
/* Replace this function only if module 'sigpipe' is requested. */
|
||||
#if GNULIB_SIGPIPE
|
||||
|
||||
/* On native Windows platforms, SIGPIPE does not exist. When write() is
|
||||
called on a pipe with no readers, WriteFile() fails with error
|
||||
GetLastError() = ERROR_NO_DATA, and write() in consequence fails with
|
||||
error EINVAL. */
|
||||
|
||||
# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
|
||||
|
||||
# include <errno.h>
|
||||
# include <signal.h>
|
||||
# include <io.h>
|
||||
|
||||
# define WIN32_LEAN_AND_MEAN /* avoid including junk */
|
||||
# include <windows.h>
|
||||
|
||||
ssize_t
|
||||
rpl_write (int fd, const void *buf, size_t count)
|
||||
#undef write
|
||||
{
|
||||
ssize_t ret = write (fd, buf, count);
|
||||
|
||||
if (ret < 0)
|
||||
{
|
||||
if (GetLastError () == ERROR_NO_DATA
|
||||
&& GetFileType (_get_osfhandle (fd)) == FILE_TYPE_PIPE)
|
||||
{
|
||||
/* Try to raise signal SIGPIPE. */
|
||||
raise (SIGPIPE);
|
||||
/* If it is currently blocked or ignored, change errno from EINVAL
|
||||
to EPIPE. */
|
||||
errno = EPIPE;
|
||||
}
|
||||
}
|
||||
return ret;
|
||||
}
|
||||
|
||||
# endif
|
||||
#endif
|
||||
|
|
@ -101,7 +101,7 @@ guile_filter_doc_snarfage$(EXEEXT): $(guile_filter_doc_snarfage_OBJECTS) $(guile
|
|||
guile_SOURCES = guile.c
|
||||
guile_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
|
||||
guile_LDADD = libguile.la
|
||||
guile_LDFLAGS = @DLPREOPEN@ $(GUILE_CFLAGS)
|
||||
guile_LDFLAGS = $(GUILE_CFLAGS)
|
||||
|
||||
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
|
||||
|
||||
|
|
@ -256,7 +256,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
|
|||
cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \
|
||||
cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \
|
||||
c-tokenize.lex version.h.in \
|
||||
scmconfig.h.top libgettext.h
|
||||
scmconfig.h.top libgettext.h measure-hwm.scm
|
||||
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
|
||||
# guile-procedures.txt guile.texi
|
||||
|
||||
|
|
@ -351,6 +351,29 @@ guile-procedures.txt: guile-procedures.texi
|
|||
|
||||
endif
|
||||
|
||||
# Stack limit calibration for `make check'. (For why we do this, see
|
||||
# the comments in measure-hwm.scm.) We're relying here on a couple of
|
||||
# bits of Automake magic.
|
||||
#
|
||||
# 1. The fact that "libguile" comes before "test-suite" in SUBDIRS in
|
||||
# our toplevel Makefile.am. This ensures that the
|
||||
# stack-limit-calibration.scm "test" will be run before any of the
|
||||
# tests under test-suite.
|
||||
#
|
||||
# 2. The fact that each test is invoked as $TESTS_ENVIRONMENT $test.
|
||||
# This allows us to ensure that the test will be considered to have
|
||||
# passed, by using `true' as TESTS_ENVIRONMENT.
|
||||
#
|
||||
# Why don't we care about the test "actually passing"? Because the
|
||||
# important thing about stack-limit-calibration.scm is just that it is
|
||||
# generated in the first place, so that other tests under test-suite
|
||||
# can use it.
|
||||
TESTS = stack-limit-calibration.scm
|
||||
TESTS_ENVIRONMENT = true
|
||||
|
||||
stack-limit-calibration.scm: measure-hwm.scm guile$(EXEEXT)
|
||||
$(preinstguile) -s $(srcdir)/measure-hwm.scm > $@
|
||||
|
||||
c-tokenize.c: c-tokenize.lex
|
||||
flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; }
|
||||
|
||||
|
|
@ -405,7 +428,7 @@ MOSTLYCLEANFILES = \
|
|||
cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \
|
||||
cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new \
|
||||
version.h version.h.tmp \
|
||||
scmconfig.h scmconfig.h.tmp
|
||||
scmconfig.h scmconfig.h.tmp stack-limit-calibration.scm
|
||||
|
||||
CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008 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
|
||||
|
|
@ -41,6 +41,8 @@
|
|||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
#include <full-write.h>
|
||||
|
||||
|
||||
/* {Asynchronous Events}
|
||||
*
|
||||
|
|
@ -241,13 +243,13 @@ scm_i_queue_async_cell (SCM c, scm_i_thread *t)
|
|||
if (sleep_fd >= 0)
|
||||
{
|
||||
char dummy = 0;
|
||||
|
||||
/* Likewise, T might already been done with sleeping here, but
|
||||
interrupting it once too often does no harm. T might also
|
||||
not yet have started sleeping, but this is no problem either
|
||||
since the data written to a pipe will not be lost, unlike a
|
||||
condition variable signal.
|
||||
*/
|
||||
write (sleep_fd, &dummy, 1);
|
||||
condition variable signal. */
|
||||
full_write (sleep_fd, &dummy, 1);
|
||||
}
|
||||
|
||||
/* This is needed to protect sleep_mutex.
|
||||
|
|
|
|||
|
|
@ -220,7 +220,7 @@ SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
|
|||
int i;
|
||||
for (i = 0; i < malloc_type_size + N_SEEK; ++i)
|
||||
if (malloc_type[i].key)
|
||||
res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key),
|
||||
res = scm_acons (scm_from_locale_string ((char *) malloc_type[i].key),
|
||||
scm_from_int ((int) malloc_type[i].data),
|
||||
res);
|
||||
return res;
|
||||
|
|
|
|||
|
|
@ -59,6 +59,8 @@
|
|||
# include <winsock2.h>
|
||||
#endif /* __MINGW32__ */
|
||||
|
||||
#include <full-write.h>
|
||||
|
||||
/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
|
||||
already, but have this code here in case that wasn't so in past versions,
|
||||
or perhaps to help other minimal DOS environments.
|
||||
|
|
@ -826,9 +828,9 @@ fport_flush (SCM port)
|
|||
const char *msg = "Error: could not flush file-descriptor ";
|
||||
char buf[11];
|
||||
|
||||
write (2, msg, strlen (msg));
|
||||
full_write (2, msg, strlen (msg));
|
||||
sprintf (buf, "%d\n", fp->fdes);
|
||||
write (2, buf, strlen (buf));
|
||||
full_write (2, buf, strlen (buf));
|
||||
|
||||
count = remaining;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1215,7 +1215,10 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
|
|||
unsigned long int i;
|
||||
|
||||
SCM_VALIDATE_INSTANCE (1, obj);
|
||||
i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
|
||||
i = scm_to_unsigned_integer (index, 0,
|
||||
SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
|
||||
scm_si_nfields))
|
||||
- 1);
|
||||
return SCM_SLOT (obj, i);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -1229,7 +1232,10 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
|
|||
unsigned long int i;
|
||||
|
||||
SCM_VALIDATE_INSTANCE (1, obj);
|
||||
i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
|
||||
i = scm_to_unsigned_integer (index, 0,
|
||||
SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
|
||||
scm_si_nfields))
|
||||
- 1);
|
||||
|
||||
SCM_SET_SLOT (obj, i, value);
|
||||
|
||||
|
|
|
|||
|
|
@ -98,8 +98,6 @@ typedef struct scm_t_method {
|
|||
/* Also defined in libguile/objects.c */
|
||||
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
|
||||
#define SCM_ACCESSORS_OF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]))
|
||||
#define SCM_NUMBER_OF_SLOTS(x) \
|
||||
((SCM_STRUCT_DATA (x)[scm_struct_i_n_words]) - scm_struct_n_extra_words)
|
||||
|
||||
#define SCM_CLASSP(x) \
|
||||
(SCM_STRUCTP (x) && SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_METACLASS)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1996,1997,2000,2001, 2006 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1996,1997,2000,2001, 2006, 2008 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
|
||||
|
|
@ -66,11 +66,6 @@ inner_main (void *closure SCM_UNUSED, int argc, char **argv)
|
|||
int
|
||||
main (int argc, char **argv)
|
||||
{
|
||||
#if !defined (__MINGW32__)
|
||||
/* libtool automagically inserts this variable into your executable... */
|
||||
extern const lt_dlsymlist lt_preloaded_symbols[];
|
||||
lt_dlpreload_default (lt_preloaded_symbols);
|
||||
#endif
|
||||
scm_boot_guile (argc, argv, inner_main, 0);
|
||||
return 0; /* never reached */
|
||||
}
|
||||
|
|
|
|||
|
|
@ -46,8 +46,10 @@
|
|||
|
||||
http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html
|
||||
|
||||
The whole API is being standardized by the X/Open Group (as of Jan. 2007)
|
||||
following Drepper's proposal. */
|
||||
The whole API was eventually standardized in the ``Open Group Base
|
||||
Specifications Issue 7'' (aka. "POSIX 2008"):
|
||||
|
||||
http://www.opengroup.org/onlinepubs/9699919799/basedefs/locale.h.html */
|
||||
# define USE_GNU_LOCALE_API
|
||||
#endif
|
||||
|
||||
|
|
|
|||
136
libguile/measure-hwm.scm
Normal file
136
libguile/measure-hwm.scm
Normal file
|
|
@ -0,0 +1,136 @@
|
|||
;;;; Copyright (C) 2008 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
|
||||
;;;;
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; This code is run during the Guile build, in order to set the stack
|
||||
;;; limit to a value that will allow the `make check' tests to pass,
|
||||
;;; taking into account the average stack usage on the build platform.
|
||||
;;; For more detail, see the text below that gets written out to the
|
||||
;;; stack limit calibration file.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;; Store off Guile's default stack limit.
|
||||
(define default-stack-limit (cadr (memq 'stack (debug-options))))
|
||||
|
||||
;; Now disable the stack limit, so that we don't get a stack overflow
|
||||
;; while running this code!
|
||||
(debug-set! stack 0)
|
||||
|
||||
;; Define a variable to hold the measured stack high water mark (HWM).
|
||||
(define top-repl-hwm-measured 0)
|
||||
|
||||
;; Use an evaluator trap to measure the stack size at every
|
||||
;; evaluation step, and increase top-repl-hwm-measured if it is less
|
||||
;; than the measured stack size.
|
||||
(trap-set! enter-frame-handler
|
||||
(lambda _
|
||||
(let ((stack-size (%get-stack-size)))
|
||||
(if (< top-repl-hwm-measured stack-size)
|
||||
(set! top-repl-hwm-measured stack-size)))))
|
||||
(trap-enable 'enter-frame)
|
||||
(trap-enable 'traps)
|
||||
|
||||
;; Call (turn-on-debugging) and (top-repl) in order to simulate as
|
||||
;; closely as possible what happens - and in particular, how much
|
||||
;; stack is used - when a standard Guile REPL is started up.
|
||||
;;
|
||||
;; `make check' stack overflow errors have been reported in the past
|
||||
;; for:
|
||||
;;
|
||||
;; - test-suite/standalone/test-use-srfi, which runs `guile -q
|
||||
;; --use-srfi=...' a few times, with standard input for the REPL
|
||||
;; coming from a shell script
|
||||
;;
|
||||
;; - test-suite/tests/elisp.test, which does not involve the REPL, but
|
||||
;; has a lot of `use-modules' calls.
|
||||
;;
|
||||
;; Stack high water mark (HWM) measurements show that the HWM is
|
||||
;; higher in the test-use-srfi case - specifically because of the
|
||||
;; complexity of (top-repl) - so that is what we simulate for our
|
||||
;; calibration model here.
|
||||
(turn-on-debugging)
|
||||
(with-output-to-port (%make-void-port "w")
|
||||
(lambda ()
|
||||
(with-input-from-string "\n" top-repl)))
|
||||
|
||||
;; top-repl-hwm-measured now contains the stack HWM that resulted from
|
||||
;; running that code.
|
||||
|
||||
;; This is the value of top-repl-hwm-measured that we get on a
|
||||
;; `canonical' build platform. (See text below for what that means.)
|
||||
(define top-repl-hwm-i686-pc-linux-gnu 9461)
|
||||
|
||||
;; Using the above results, output code that tests can run in order to
|
||||
;; configure the stack limit correctly for the current build platform.
|
||||
(format #t "\
|
||||
;; Stack limit calibration file.
|
||||
;;
|
||||
;; This file is automatically generated by Guile when it builds, in
|
||||
;; order to set the stack limit to a value that reflects the stack
|
||||
;; usage of the build platform (OS + compiler + compilation options),
|
||||
;; specifically so that none of Guile's own tests (which are run by
|
||||
;; `make check') fail because of a benign stack overflow condition.
|
||||
;;
|
||||
;; By a `benign' stack overflow condition, we mean one where the test
|
||||
;; code is behaving correctly, but exceeds the configured stack limit
|
||||
;; because the limit is set too low. A non-benign stack overflow
|
||||
;; condition would be if a piece of test code behaved significantly
|
||||
;; differently on some platform to how it does normally, and as a
|
||||
;; result consumed a lot more stack. Although they seem pretty
|
||||
;; unlikely, we would want to catch non-benign conditions like this,
|
||||
;; and that is why we don't just do `(debug-set! stack 0)' when
|
||||
;; running `make check'.
|
||||
;;
|
||||
;; Although the primary purpose of this file is to prevent `make
|
||||
;; check' from failing without good reason, Guile developers and users
|
||||
;; may also find the following information useful, when determining
|
||||
;; what stack limit to configure for their own programs.
|
||||
|
||||
(let (;; The stack high water mark measured when starting up the
|
||||
;; standard Guile REPL on the current build platform.
|
||||
(top-repl-hwm-measured ~a)
|
||||
|
||||
;; The value of top-repl-hwm-measured that we get when building
|
||||
;; Guile on an i686 PC GNU/Linux system, after configuring with
|
||||
;; `./configure --enable-maintainer-mode --with-threads'.
|
||||
;; (Hereafter referred to as the `canonical' build platform.)
|
||||
(top-repl-hwm-i686-pc-linux-gnu ~a)
|
||||
|
||||
;; Guile's default stack limit (i.e. the initial, C-coded value
|
||||
;; of the 'stack debug option). In the context of this file,
|
||||
;; the important thing about this number is that we know that
|
||||
;; it allows all of the `make check' tests to pass on the
|
||||
;; canonical build platform.
|
||||
(default-stack-limit ~a)
|
||||
|
||||
;; Calibrated stack limit. This is the default stack limit,
|
||||
;; scaled by the factor between top-repl-hwm-i686-pc-linux-gnu
|
||||
;; and top-repl-hwm-measured.
|
||||
(calibrated-stack-limit ~a))
|
||||
|
||||
;; Configure the calibrated stack limit.
|
||||
(debug-set! stack calibrated-stack-limit))
|
||||
"
|
||||
top-repl-hwm-measured
|
||||
top-repl-hwm-i686-pc-linux-gnu
|
||||
default-stack-limit
|
||||
;; Use quotient here to get an integer result, rather than a
|
||||
;; rational.
|
||||
(quotient (* default-stack-limit top-repl-hwm-measured)
|
||||
top-repl-hwm-i686-pc-linux-gnu))
|
||||
|
|
@ -1073,14 +1073,20 @@ scm_c_read (SCM port, void *buffer, size_t size)
|
|||
/* Now we will call scm_fill_input repeatedly until we have read the
|
||||
requested number of bytes. (Note that a single scm_fill_input
|
||||
call does not guarantee to fill the whole of the port's read
|
||||
buffer.) For these calls, since we already have a buffer here to
|
||||
read into, we bypass the port's own read buffer (if it has one),
|
||||
by saving it off and modifying the port structure to point to our
|
||||
own buffer.
|
||||
buffer.) */
|
||||
if (pt->read_buf_size <= 1)
|
||||
{
|
||||
/* The port that we are reading from is unbuffered - i.e. does
|
||||
not have its own persistent buffer - but we have a buffer,
|
||||
provided by our caller, that is the right size for the data
|
||||
that is wanted. For the following scm_fill_input calls,
|
||||
therefore, we use the buffer in hand as the port's read
|
||||
buffer.
|
||||
|
||||
We need to make sure that the port's normal buffer is reinstated
|
||||
in case one of the scm_fill_input () calls throws an exception;
|
||||
we use the scm_dynwind_* API to achieve that. */
|
||||
We need to make sure that the port's normal (1 byte) buffer
|
||||
is reinstated in case one of the scm_fill_input () calls
|
||||
throws an exception; we use the scm_dynwind_* API to achieve
|
||||
that. */
|
||||
psb.pt = pt;
|
||||
psb.buffer = buffer;
|
||||
psb.size = size;
|
||||
|
|
@ -1088,8 +1094,8 @@ scm_c_read (SCM port, void *buffer, size_t size)
|
|||
scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
|
||||
scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
|
||||
|
||||
/* Call scm_fill_input until we have all the bytes that we need, or
|
||||
we hit EOF. */
|
||||
/* Call scm_fill_input until we have all the bytes that we need,
|
||||
or we hit EOF. */
|
||||
while (pt->read_buf_size && (scm_fill_input (port) != EOF))
|
||||
{
|
||||
pt->read_buf_size -= (pt->read_end - pt->read_pos);
|
||||
|
|
@ -1099,6 +1105,24 @@ scm_c_read (SCM port, void *buffer, size_t size)
|
|||
|
||||
/* Reinstate the port's normal buffer. */
|
||||
scm_dynwind_end ();
|
||||
}
|
||||
else
|
||||
{
|
||||
/* The port has its own buffer. It is important that we use it,
|
||||
even if it happens to be smaller than our caller's buffer, so
|
||||
that a custom port implementation's entry points (in
|
||||
particular, fill_input) can rely on the buffer always being
|
||||
the same as they first set up. */
|
||||
while (size && (scm_fill_input (port) != EOF))
|
||||
{
|
||||
n_available = min (size, pt->read_end - pt->read_pos);
|
||||
memcpy (buffer, pt->read_pos, n_available);
|
||||
buffer = (char *) buffer + n_available;
|
||||
pt->read_pos += n_available;
|
||||
n_read += n_available;
|
||||
size -= n_available;
|
||||
}
|
||||
}
|
||||
|
||||
return n_read;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -277,7 +277,7 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
|
|||
|
||||
size = ngroups * sizeof (GETGROUPS_T);
|
||||
groups = scm_malloc (size);
|
||||
getgroups (ngroups, groups);
|
||||
ngroups = getgroups (ngroups, groups);
|
||||
|
||||
result = scm_c_make_vector (ngroups, SCM_BOOL_F);
|
||||
while (--ngroups >= 0)
|
||||
|
|
@ -1563,12 +1563,15 @@ SCM_DEFINE (scm_nice, "nice", 1, 0, 0,
|
|||
"The return value is unspecified.")
|
||||
#define FUNC_NAME s_scm_nice
|
||||
{
|
||||
int nice_value;
|
||||
|
||||
/* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise
|
||||
from "prio-NZERO", so an error must be detected from errno changed */
|
||||
errno = 0;
|
||||
nice (scm_to_int (incr));
|
||||
nice_value = nice (scm_to_int (incr));
|
||||
if (errno != 0)
|
||||
SCM_SYSERROR;
|
||||
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
|
|||
|
|
@ -484,7 +484,7 @@ scm_read_string (int chr, SCM port)
|
|||
else
|
||||
str = (str == SCM_BOOL_F) ? scm_nullstr : str;
|
||||
|
||||
return scm_i_make_read_only_string (str);
|
||||
return str;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -63,6 +63,9 @@
|
|||
#define pipe(fd) _pipe (fd, 256, O_BINARY)
|
||||
#endif
|
||||
|
||||
#include <full-write.h>
|
||||
|
||||
|
||||
|
||||
|
||||
/* SIGRETTYPE is the type that signal handlers return. See <signal.h> */
|
||||
|
|
@ -137,7 +140,7 @@ static SIGRETTYPE
|
|||
take_signal (int signum)
|
||||
{
|
||||
char sigbyte = signum;
|
||||
write (signal_pipe[1], &sigbyte, 1);
|
||||
full_write (signal_pipe[1], &sigbyte, 1);
|
||||
|
||||
#ifndef HAVE_SIGACTION
|
||||
signal (signum, take_signal);
|
||||
|
|
|
|||
|
|
@ -384,9 +384,7 @@ scm_shell_usage (int fatal, char *message)
|
|||
" -v, --version display version information and exit\n"
|
||||
" \\ read arguments from following script lines\n"
|
||||
"\n"
|
||||
"Please report bugs to bug-guile@gnu.org. (Note that you must\n"
|
||||
"be subscribed to this list first, in order to successfully send\n"
|
||||
"a report to it).\n",
|
||||
"Please report bugs to bug-guile@gnu.org\n",
|
||||
scm_usage_name);
|
||||
|
||||
if (fatal)
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@
|
|||
#include "libguile/_scm.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/threads.h"
|
||||
|
||||
#include "libguile/stackchk.h"
|
||||
|
||||
|
|
@ -78,6 +79,17 @@ scm_stack_report ()
|
|||
scm_puts ("\n", port);
|
||||
}
|
||||
|
||||
|
||||
SCM_DEFINE (scm_sys_get_stack_size, "%get-stack-size", 0, 0, 0,
|
||||
(),
|
||||
"Return the current thread's C stack size (in Scheme objects).")
|
||||
#define FUNC_NAME s_scm_sys_get_stack_size
|
||||
{
|
||||
return scm_from_long (scm_stack_size (SCM_I_CURRENT_THREAD->base));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
void
|
||||
scm_init_stackchk ()
|
||||
{
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@ SCM_API int scm_stack_checking_enabled_p;
|
|||
SCM_API void scm_report_stack_overflow (void);
|
||||
SCM_API long scm_stack_size (SCM_STACKITEM *start);
|
||||
SCM_API void scm_stack_report (void);
|
||||
SCM_API SCM scm_sys_get_stack_size (void);
|
||||
SCM_INTERNAL void scm_init_stackchk (void);
|
||||
|
||||
#endif /* SCM_STACKCHK_H */
|
||||
|
|
|
|||
|
|
@ -217,12 +217,6 @@ get_str_buf_start (SCM *str, SCM *buf, size_t *start)
|
|||
*buf = STRING_STRINGBUF (*str);
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_i_make_read_only_string (SCM str)
|
||||
{
|
||||
return scm_i_substring_read_only (str, 0, STRING_LENGTH (str));
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_i_substring (SCM str, size_t start, size_t end)
|
||||
{
|
||||
|
|
@ -240,28 +234,15 @@ scm_i_substring (SCM str, size_t start, size_t end)
|
|||
SCM
|
||||
scm_i_substring_read_only (SCM str, size_t start, size_t end)
|
||||
{
|
||||
SCM result;
|
||||
|
||||
if (SCM_UNLIKELY (STRING_LENGTH (str) == 0))
|
||||
/* We want the empty string to be `eq?' with the read-only empty
|
||||
string. */
|
||||
result = str;
|
||||
else
|
||||
{
|
||||
SCM buf;
|
||||
size_t str_start;
|
||||
|
||||
get_str_buf_start (&str, &buf, &str_start);
|
||||
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
|
||||
SET_STRINGBUF_SHARED (buf);
|
||||
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
|
||||
|
||||
result = scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf),
|
||||
(scm_t_bits) str_start + start,
|
||||
return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
|
||||
(scm_t_bits)str_start + start,
|
||||
(scm_t_bits) end - start);
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -689,10 +670,17 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
|
|||
"indexing. @var{k} must be a valid index of @var{str}.")
|
||||
#define FUNC_NAME s_scm_string_ref
|
||||
{
|
||||
size_t len;
|
||||
unsigned long idx;
|
||||
|
||||
SCM_VALIDATE_STRING (1, str);
|
||||
idx = scm_to_unsigned_integer (k, 0, scm_i_string_length (str)-1);
|
||||
|
||||
len = scm_i_string_length (str);
|
||||
if (SCM_LIKELY (len > 0))
|
||||
idx = scm_to_unsigned_integer (k, 0, len - 1);
|
||||
else
|
||||
scm_out_of_range (NULL, k);
|
||||
|
||||
return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -712,10 +700,17 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
|
|||
"@var{str}.")
|
||||
#define FUNC_NAME s_scm_string_set_x
|
||||
{
|
||||
size_t len;
|
||||
unsigned long idx;
|
||||
|
||||
SCM_VALIDATE_STRING (1, str);
|
||||
idx = scm_to_unsigned_integer (k, 0, scm_i_string_length(str)-1);
|
||||
|
||||
len = scm_i_string_length (str);
|
||||
if (SCM_LIKELY (len > 0))
|
||||
idx = scm_to_unsigned_integer (k, 0, len - 1);
|
||||
else
|
||||
scm_out_of_range (NULL, k);
|
||||
|
||||
SCM_VALIDATE_CHAR (3, chr);
|
||||
{
|
||||
char *dst = scm_i_string_writable_chars (str);
|
||||
|
|
|
|||
|
|
@ -152,7 +152,6 @@ SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
|
|||
SCM start, size_t *cstart,
|
||||
SCM end, size_t *cend);
|
||||
SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len);
|
||||
SCM_INTERNAL SCM scm_i_make_read_only_string (SCM str);
|
||||
|
||||
/* deprecated stuff */
|
||||
|
||||
|
|
|
|||
|
|
@ -450,7 +450,13 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
goto bad_tail;
|
||||
}
|
||||
|
||||
SCM_CRITICAL_SECTION_START;
|
||||
/* In guile 1.8.5 and earlier, everything below was covered by a
|
||||
CRITICAL_SECTION lock. This can lead to deadlocks in garbage
|
||||
collection, since other threads might be holding the heap_mutex, while
|
||||
sleeping on the CRITICAL_SECTION lock. There does not seem to be any
|
||||
need for a lock on the section below, as it does not access or update
|
||||
any globals, so the critical section has been removed. */
|
||||
|
||||
if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
|
||||
{
|
||||
data = scm_alloc_struct (basic_size + tail_elts,
|
||||
|
|
@ -466,15 +472,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable))
|
||||
+ scm_tc3_struct),
|
||||
(scm_t_bits) data, 0, 0);
|
||||
SCM_CRITICAL_SECTION_END;
|
||||
|
||||
/* In guile 1.8.1 and earlier, the SCM_CRITICAL_SECTION_END above covered
|
||||
also the following scm_struct_init. But that meant if scm_struct_init
|
||||
finds an invalid type for a "u" field then there's an error throw in a
|
||||
critical section, which results in an abort(). Not sure if we need any
|
||||
protection across scm_struct_init. The data array contains garbage at
|
||||
this point, but until we return it's not visible to anyone except
|
||||
`gc'. */
|
||||
scm_struct_init (handle, layout, data, tail_elts, init);
|
||||
|
||||
return handle;
|
||||
|
|
|
|||
|
|
@ -61,6 +61,9 @@
|
|||
# define pipe(fd) _pipe (fd, 256, O_BINARY)
|
||||
#endif /* __MINGW32__ */
|
||||
|
||||
#include <full-read.h>
|
||||
|
||||
|
||||
static void
|
||||
to_timespec (SCM t, scm_t_timespec *waittime)
|
||||
{
|
||||
|
|
@ -481,8 +484,13 @@ guilify_self_1 (SCM_STACKITEM *base)
|
|||
t->sleep_mutex = NULL;
|
||||
t->sleep_object = SCM_BOOL_F;
|
||||
t->sleep_fd = -1;
|
||||
/* XXX - check for errors. */
|
||||
pipe (t->sleep_pipe);
|
||||
|
||||
if (pipe (t->sleep_pipe) != 0)
|
||||
/* FIXME: Error conditions during the initialization phase are handled
|
||||
gracelessly since public functions such as `scm_init_guile ()'
|
||||
currently have type `void'. */
|
||||
abort ();
|
||||
|
||||
scm_i_pthread_mutex_init (&t->heap_mutex, NULL);
|
||||
scm_i_pthread_mutex_init (&t->admin_mutex, NULL);
|
||||
t->clear_freelists_p = 0;
|
||||
|
|
@ -700,9 +708,18 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
|
|||
/* This thread is already guilified but not in guile mode, just
|
||||
resume it.
|
||||
|
||||
XXX - base might be lower than when this thread was first
|
||||
guilified.
|
||||
*/
|
||||
A user call to scm_with_guile() will lead us to here. This could
|
||||
happen from anywhere on the stack, and in particular lower on the
|
||||
stack than when it was when this thread was first guilified. Thus,
|
||||
`base' must be updated. */
|
||||
#if SCM_STACK_GROWS_UP
|
||||
if (base < t->base)
|
||||
t->base = base;
|
||||
#else
|
||||
if (base > t->base)
|
||||
t->base = base;
|
||||
#endif
|
||||
|
||||
scm_enter_guile ((scm_t_guile_ticket) t);
|
||||
return 1;
|
||||
}
|
||||
|
|
@ -1723,7 +1740,7 @@ scm_threads_mark_stacks (void)
|
|||
#else
|
||||
scm_mark_locations (t->top, t->base - t->top);
|
||||
#endif
|
||||
scm_mark_locations ((SCM_STACKITEM *) &t->regs,
|
||||
scm_mark_locations ((void *) &t->regs,
|
||||
((size_t) sizeof(t->regs)
|
||||
/ sizeof (SCM_STACKITEM)));
|
||||
}
|
||||
|
|
@ -1769,7 +1786,8 @@ scm_std_select (int nfds,
|
|||
if (res > 0 && FD_ISSET (wakeup_fd, readfds))
|
||||
{
|
||||
char dummy;
|
||||
read (wakeup_fd, &dummy, 1);
|
||||
full_read (wakeup_fd, &dummy, 1);
|
||||
|
||||
FD_CLR (wakeup_fd, readfds);
|
||||
res -= 1;
|
||||
if (res == 0)
|
||||
|
|
|
|||
2
m4/.gitignore
vendored
Normal file
2
m4/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
/libtool.m4
|
||||
/lt*.m4
|
||||
|
|
@ -15,7 +15,7 @@
|
|||
|
||||
|
||||
# Specification in the form of a command-line invocation:
|
||||
# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl alloca autobuild count-one-bits extensions strcase strftime
|
||||
# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl alloca autobuild count-one-bits extensions full-read full-write strcase strftime
|
||||
|
||||
# Specification in the form of a few gnulib-tool.m4 macro invocations:
|
||||
gl_LOCAL_DIR([])
|
||||
|
|
@ -24,6 +24,8 @@ gl_MODULES([
|
|||
autobuild
|
||||
count-one-bits
|
||||
extensions
|
||||
full-read
|
||||
full-write
|
||||
strcase
|
||||
strftime
|
||||
])
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# gnulib-common.m4 serial 5
|
||||
# gnulib-common.m4 serial 6
|
||||
dnl Copyright (C) 2007-2008 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
|
|
@ -21,6 +21,16 @@ AC_DEFUN([gl_COMMON_BODY], [
|
|||
#if defined __APPLE__ && defined __MACH__ && __APPLE_CC__ >= 5465 && !defined __cplusplus && __STDC_VERSION__ >= 199901L && !defined __GNUC_STDC_INLINE__
|
||||
# define __GNUC_STDC_INLINE__ 1
|
||||
#endif])
|
||||
AH_VERBATIM([unused_parameter],
|
||||
[/* Define as a marker that can be attached to function parameter declarations
|
||||
for parameters that are not used. This helps to reduce warnings, such as
|
||||
from GCC -Wunused-parameter. */
|
||||
#if __GNUC__ >= 3 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7)
|
||||
# define _UNUSED_PARAMETER_ __attribute__ ((__unused__))
|
||||
#else
|
||||
# define _UNUSED_PARAMETER_
|
||||
#endif
|
||||
])
|
||||
])
|
||||
|
||||
# gl_MODULE_INDICATOR([modulename])
|
||||
|
|
|
|||
|
|
@ -49,13 +49,19 @@ AC_SUBST([LTALLOCA])
|
|||
gl_FUNC_ALLOCA
|
||||
gl_COUNT_ONE_BITS
|
||||
gl_INLINE
|
||||
gl_SAFE_READ
|
||||
gl_SAFE_WRITE
|
||||
gt_TYPE_SSIZE_T
|
||||
AM_STDBOOL_H
|
||||
gl_STRCASE
|
||||
gl_FUNC_GNU_STRFTIME
|
||||
gl_HEADER_STRINGS_H
|
||||
gl_HEADER_TIME_H
|
||||
gl_TIME_R
|
||||
gl_UNISTD_H
|
||||
gl_WCHAR_H
|
||||
gl_FUNC_WRITE
|
||||
gl_UNISTD_MODULE_INDICATOR([write])
|
||||
m4_ifval(gl_LIBSOURCES_LIST, [
|
||||
m4_syscmd([test ! -d ]m4_defn([gl_LIBSOURCES_DIR])[ ||
|
||||
for gl_file in ]gl_LIBSOURCES_LIST[ ; do
|
||||
|
|
@ -188,7 +194,14 @@ AC_DEFUN([gl_FILE_LIST], [
|
|||
lib/alloca.c
|
||||
lib/alloca.in.h
|
||||
lib/count-one-bits.h
|
||||
lib/dummy.c
|
||||
lib/full-read.c
|
||||
lib/full-read.h
|
||||
lib/full-write.c
|
||||
lib/full-write.h
|
||||
lib/safe-read.c
|
||||
lib/safe-read.h
|
||||
lib/safe-write.c
|
||||
lib/safe-write.h
|
||||
lib/stdbool.in.h
|
||||
lib/strcasecmp.c
|
||||
lib/strftime.c
|
||||
|
|
@ -197,8 +210,10 @@ AC_DEFUN([gl_FILE_LIST], [
|
|||
lib/strncasecmp.c
|
||||
lib/time.in.h
|
||||
lib/time_r.c
|
||||
lib/unistd.in.h
|
||||
lib/verify.h
|
||||
lib/wchar.in.h
|
||||
lib/write.c
|
||||
m4/alloca.m4
|
||||
m4/autobuild.m4
|
||||
m4/count-one-bits.m4
|
||||
|
|
@ -207,6 +222,9 @@ AC_DEFUN([gl_FILE_LIST], [
|
|||
m4/include_next.m4
|
||||
m4/inline.m4
|
||||
m4/mbstate_t.m4
|
||||
m4/safe-read.m4
|
||||
m4/safe-write.m4
|
||||
m4/ssize_t.m4
|
||||
m4/stdbool.m4
|
||||
m4/strcase.m4
|
||||
m4/strftime.m4
|
||||
|
|
@ -214,5 +232,8 @@ AC_DEFUN([gl_FILE_LIST], [
|
|||
m4/time_h.m4
|
||||
m4/time_r.m4
|
||||
m4/tm_gmtoff.m4
|
||||
m4/unistd_h.m4
|
||||
m4/wchar.m4
|
||||
m4/wint_t.m4
|
||||
m4/write.m4
|
||||
])
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# include_next.m4 serial 7
|
||||
# include_next.m4 serial 10
|
||||
dnl Copyright (C) 2006-2008 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
|
|
@ -11,6 +11,10 @@ dnl
|
|||
dnl INCLUDE_NEXT expands to 'include_next' if the compiler supports it, or to
|
||||
dnl 'include' otherwise.
|
||||
dnl
|
||||
dnl INCLUDE_NEXT_AS_FIRST_DIRECTIVE expands to 'include_next' if the compiler
|
||||
dnl supports it in the special case that it is the first include directive in
|
||||
dnl the given file, or to 'include' otherwise.
|
||||
dnl
|
||||
dnl PRAGMA_SYSTEM_HEADER can be used in files that contain #include_next,
|
||||
dnl so as to avoid GCC warnings when the gcc option -pedantic is used.
|
||||
dnl '#pragma GCC system_header' has the same effect as if the file was found
|
||||
|
|
@ -26,9 +30,17 @@ AC_DEFUN([gl_INCLUDE_NEXT],
|
|||
AC_LANG_PREPROC_REQUIRE()
|
||||
AC_CACHE_CHECK([whether the preprocessor supports include_next],
|
||||
[gl_cv_have_include_next],
|
||||
[rm -rf conftestd1 conftestd2
|
||||
mkdir conftestd1 conftestd2
|
||||
cat <<EOF > conftestd1/conftest.h
|
||||
[rm -rf conftestd1a conftestd1b conftestd2
|
||||
mkdir conftestd1a conftestd1b conftestd2
|
||||
dnl The include of <stdio.h> is because IBM C 9.0 on AIX 6.1 supports
|
||||
dnl include_next when used as first preprocessor directive in a file,
|
||||
dnl but not when preceded by another include directive. Additionally,
|
||||
dnl with this same compiler, include_next is a no-op when used in a
|
||||
dnl header file that was included by specifying its absolute file name.
|
||||
dnl Despite these two bugs, include_next is used in the compiler's
|
||||
dnl <math.h>. By virtue of the second bug, we need to use include_next
|
||||
dnl as well in this case.
|
||||
cat <<EOF > conftestd1a/conftest.h
|
||||
#define DEFINED_IN_CONFTESTD1
|
||||
#include_next <conftest.h>
|
||||
#ifdef DEFINED_IN_CONFTESTD2
|
||||
|
|
@ -36,6 +48,16 @@ int foo;
|
|||
#else
|
||||
#error "include_next doesn't work"
|
||||
#endif
|
||||
EOF
|
||||
cat <<EOF > conftestd1b/conftest.h
|
||||
#define DEFINED_IN_CONFTESTD1
|
||||
#include <stdio.h>
|
||||
#include_next <conftest.h>
|
||||
#ifdef DEFINED_IN_CONFTESTD2
|
||||
int foo;
|
||||
#else
|
||||
#error "include_next doesn't work"
|
||||
#endif
|
||||
EOF
|
||||
cat <<EOF > conftestd2/conftest.h
|
||||
#ifndef DEFINED_IN_CONFTESTD1
|
||||
|
|
@ -43,24 +65,36 @@ EOF
|
|||
#endif
|
||||
#define DEFINED_IN_CONFTESTD2
|
||||
EOF
|
||||
save_CPPFLAGS="$CPPFLAGS"
|
||||
CPPFLAGS="$CPPFLAGS -Iconftestd1 -Iconftestd2"
|
||||
gl_save_CPPFLAGS="$CPPFLAGS"
|
||||
CPPFLAGS="$gl_save_CPPFLAGS -Iconftestd1b -Iconftestd2"
|
||||
AC_COMPILE_IFELSE([#include <conftest.h>],
|
||||
[gl_cv_have_include_next=yes],
|
||||
[CPPFLAGS="$gl_save_CPPFLAGS -Iconftestd1a -Iconftestd2"
|
||||
AC_COMPILE_IFELSE([#include <conftest.h>],
|
||||
[gl_cv_have_include_next=buggy],
|
||||
[gl_cv_have_include_next=no])
|
||||
CPPFLAGS="$save_CPPFLAGS"
|
||||
rm -rf conftestd1 conftestd2
|
||||
])
|
||||
CPPFLAGS="$gl_save_CPPFLAGS"
|
||||
rm -rf conftestd1a conftestd1b conftestd2
|
||||
])
|
||||
PRAGMA_SYSTEM_HEADER=
|
||||
if test $gl_cv_have_include_next = yes; then
|
||||
INCLUDE_NEXT=include_next
|
||||
INCLUDE_NEXT_AS_FIRST_DIRECTIVE=include_next
|
||||
if test -n "$GCC"; then
|
||||
PRAGMA_SYSTEM_HEADER='#pragma GCC system_header'
|
||||
fi
|
||||
else
|
||||
if test $gl_cv_have_include_next = buggy; then
|
||||
INCLUDE_NEXT=include
|
||||
INCLUDE_NEXT_AS_FIRST_DIRECTIVE=include_next
|
||||
else
|
||||
INCLUDE_NEXT=include
|
||||
INCLUDE_NEXT_AS_FIRST_DIRECTIVE=include
|
||||
fi
|
||||
fi
|
||||
AC_SUBST([INCLUDE_NEXT])
|
||||
AC_SUBST([INCLUDE_NEXT_AS_FIRST_DIRECTIVE])
|
||||
AC_SUBST([PRAGMA_SYSTEM_HEADER])
|
||||
])
|
||||
|
||||
|
|
@ -83,6 +117,7 @@ EOF
|
|||
AC_DEFUN([gl_CHECK_NEXT_HEADERS],
|
||||
[
|
||||
AC_REQUIRE([gl_INCLUDE_NEXT])
|
||||
AC_REQUIRE([AC_CANONICAL_HOST])
|
||||
AC_CHECK_HEADERS_ONCE([$1])
|
||||
|
||||
m4_foreach_w([gl_HEADER_NAME], [$1],
|
||||
|
|
@ -101,11 +136,22 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS],
|
|||
[AC_LANG_SOURCE(
|
||||
[[#include <]]m4_dquote(m4_defn([gl_HEADER_NAME]))[[>]]
|
||||
)])
|
||||
dnl eval is necessary to expand ac_cpp.
|
||||
dnl AIX "xlc -E" and "cc -E" omit #line directives for header files
|
||||
dnl that contain only a #include of other header files and no
|
||||
dnl non-comment tokens of their own. This leads to a failure to
|
||||
dnl detect the absolute name of <dirent.h>, <signal.h>, <poll.h>
|
||||
dnl and others. The workaround is to force preservation of comments
|
||||
dnl through option -C. This ensures all necessary #line directives
|
||||
dnl are present. GCC supports option -C as well.
|
||||
case "$host_os" in
|
||||
aix*) gl_absname_cpp="$ac_cpp -C" ;;
|
||||
*) gl_absname_cpp="$ac_cpp" ;;
|
||||
esac
|
||||
dnl eval is necessary to expand gl_absname_cpp.
|
||||
dnl Ultrix and Pyramid sh refuse to redirect output of eval,
|
||||
dnl so use subshell.
|
||||
AS_VAR_SET([gl_next_header],
|
||||
['"'`(eval "$ac_cpp conftest.$ac_ext") 2>&AS_MESSAGE_LOG_FD |
|
||||
['"'`(eval "$gl_absname_cpp conftest.$ac_ext") 2>&AS_MESSAGE_LOG_FD |
|
||||
sed -n '\#/]m4_quote(m4_defn([gl_HEADER_NAME]))[#{
|
||||
s#.*"\(.*/]m4_quote(m4_defn([gl_HEADER_NAME]))[\)".*#\1#
|
||||
s#^/[^/]#//&#
|
||||
|
|
|
|||
18
m4/safe-read.m4
Normal file
18
m4/safe-read.m4
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
# safe-read.m4 serial 5
|
||||
dnl Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
dnl with or without modifications, as long as this notice is preserved.
|
||||
|
||||
AC_DEFUN([gl_SAFE_READ],
|
||||
[
|
||||
AC_LIBOBJ([safe-read])
|
||||
|
||||
gl_PREREQ_SAFE_READ
|
||||
])
|
||||
|
||||
# Prerequisites of lib/safe-read.c.
|
||||
AC_DEFUN([gl_PREREQ_SAFE_READ],
|
||||
[
|
||||
AC_REQUIRE([gt_TYPE_SSIZE_T])
|
||||
])
|
||||
18
m4/safe-write.m4
Normal file
18
m4/safe-write.m4
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
# safe-write.m4 serial 3
|
||||
dnl Copyright (C) 2002, 2005, 2006 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
dnl with or without modifications, as long as this notice is preserved.
|
||||
|
||||
AC_DEFUN([gl_SAFE_WRITE],
|
||||
[
|
||||
AC_LIBOBJ([safe-write])
|
||||
|
||||
gl_PREREQ_SAFE_WRITE
|
||||
])
|
||||
|
||||
# Prerequisites of lib/safe-write.c.
|
||||
AC_DEFUN([gl_PREREQ_SAFE_WRITE],
|
||||
[
|
||||
gl_PREREQ_SAFE_READ
|
||||
])
|
||||
21
m4/ssize_t.m4
Normal file
21
m4/ssize_t.m4
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
# ssize_t.m4 serial 4 (gettext-0.15)
|
||||
dnl Copyright (C) 2001-2003, 2006 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
dnl with or without modifications, as long as this notice is preserved.
|
||||
|
||||
dnl From Bruno Haible.
|
||||
dnl Test whether ssize_t is defined.
|
||||
|
||||
AC_DEFUN([gt_TYPE_SSIZE_T],
|
||||
[
|
||||
AC_CACHE_CHECK([for ssize_t], [gt_cv_ssize_t],
|
||||
[AC_TRY_COMPILE([#include <sys/types.h>],
|
||||
[int x = sizeof (ssize_t *) + sizeof (ssize_t);
|
||||
return !x;],
|
||||
[gt_cv_ssize_t=yes], [gt_cv_ssize_t=no])])
|
||||
if test $gt_cv_ssize_t = no; then
|
||||
AC_DEFINE([ssize_t], [int],
|
||||
[Define as a signed type of the same size as size_t.])
|
||||
fi
|
||||
])
|
||||
81
m4/unistd_h.m4
Normal file
81
m4/unistd_h.m4
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
# unistd_h.m4 serial 16
|
||||
dnl Copyright (C) 2006-2008 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
dnl with or without modifications, as long as this notice is preserved.
|
||||
|
||||
dnl Written by Simon Josefsson, Bruno Haible.
|
||||
|
||||
AC_DEFUN([gl_UNISTD_H],
|
||||
[
|
||||
dnl Use AC_REQUIRE here, so that the default behavior below is expanded
|
||||
dnl once only, before all statements that occur in other macros.
|
||||
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
|
||||
|
||||
gl_CHECK_NEXT_HEADERS([unistd.h])
|
||||
|
||||
AC_CHECK_HEADERS_ONCE([unistd.h])
|
||||
if test $ac_cv_header_unistd_h = yes; then
|
||||
HAVE_UNISTD_H=1
|
||||
else
|
||||
HAVE_UNISTD_H=0
|
||||
fi
|
||||
AC_SUBST([HAVE_UNISTD_H])
|
||||
])
|
||||
|
||||
AC_DEFUN([gl_UNISTD_MODULE_INDICATOR],
|
||||
[
|
||||
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
|
||||
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
|
||||
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
|
||||
])
|
||||
|
||||
AC_DEFUN([gl_UNISTD_H_DEFAULTS],
|
||||
[
|
||||
GNULIB_CHOWN=0; AC_SUBST([GNULIB_CHOWN])
|
||||
GNULIB_CLOSE=0; AC_SUBST([GNULIB_CLOSE])
|
||||
GNULIB_DUP2=0; AC_SUBST([GNULIB_DUP2])
|
||||
GNULIB_ENVIRON=0; AC_SUBST([GNULIB_ENVIRON])
|
||||
GNULIB_EUIDACCESS=0; AC_SUBST([GNULIB_EUIDACCESS])
|
||||
GNULIB_FCHDIR=0; AC_SUBST([GNULIB_FCHDIR])
|
||||
GNULIB_FSYNC=0; AC_SUBST([GNULIB_FSYNC])
|
||||
GNULIB_FTRUNCATE=0; AC_SUBST([GNULIB_FTRUNCATE])
|
||||
GNULIB_GETCWD=0; AC_SUBST([GNULIB_GETCWD])
|
||||
GNULIB_GETDOMAINNAME=0; AC_SUBST([GNULIB_GETDOMAINNAME])
|
||||
GNULIB_GETDTABLESIZE=0; AC_SUBST([GNULIB_GETDTABLESIZE])
|
||||
GNULIB_GETHOSTNAME=0; AC_SUBST([GNULIB_GETHOSTNAME])
|
||||
GNULIB_GETLOGIN_R=0; AC_SUBST([GNULIB_GETLOGIN_R])
|
||||
GNULIB_GETPAGESIZE=0; AC_SUBST([GNULIB_GETPAGESIZE])
|
||||
GNULIB_GETUSERSHELL=0; AC_SUBST([GNULIB_GETUSERSHELL])
|
||||
GNULIB_LCHOWN=0; AC_SUBST([GNULIB_LCHOWN])
|
||||
GNULIB_LSEEK=0; AC_SUBST([GNULIB_LSEEK])
|
||||
GNULIB_READLINK=0; AC_SUBST([GNULIB_READLINK])
|
||||
GNULIB_SLEEP=0; AC_SUBST([GNULIB_SLEEP])
|
||||
GNULIB_UNISTD_H_SIGPIPE=0; AC_SUBST([GNULIB_UNISTD_H_SIGPIPE])
|
||||
GNULIB_WRITE=0; AC_SUBST([GNULIB_WRITE])
|
||||
dnl Assume proper GNU behavior unless another module says otherwise.
|
||||
HAVE_DUP2=1; AC_SUBST([HAVE_DUP2])
|
||||
HAVE_EUIDACCESS=1; AC_SUBST([HAVE_EUIDACCESS])
|
||||
HAVE_FSYNC=1; AC_SUBST([HAVE_FSYNC])
|
||||
HAVE_FTRUNCATE=1; AC_SUBST([HAVE_FTRUNCATE])
|
||||
HAVE_GETDOMAINNAME=1; AC_SUBST([HAVE_GETDOMAINNAME])
|
||||
HAVE_GETDTABLESIZE=1; AC_SUBST([HAVE_GETDTABLESIZE])
|
||||
HAVE_GETHOSTNAME=1; AC_SUBST([HAVE_GETHOSTNAME])
|
||||
HAVE_GETPAGESIZE=1; AC_SUBST([HAVE_GETPAGESIZE])
|
||||
HAVE_GETUSERSHELL=1; AC_SUBST([HAVE_GETUSERSHELL])
|
||||
HAVE_READLINK=1; AC_SUBST([HAVE_READLINK])
|
||||
HAVE_SLEEP=1; AC_SUBST([HAVE_SLEEP])
|
||||
HAVE_DECL_ENVIRON=1; AC_SUBST([HAVE_DECL_ENVIRON])
|
||||
HAVE_DECL_GETLOGIN_R=1; AC_SUBST([HAVE_DECL_GETLOGIN_R])
|
||||
HAVE_OS_H=0; AC_SUBST([HAVE_OS_H])
|
||||
HAVE_SYS_PARAM_H=0; AC_SUBST([HAVE_SYS_PARAM_H])
|
||||
REPLACE_CHOWN=0; AC_SUBST([REPLACE_CHOWN])
|
||||
REPLACE_CLOSE=0; AC_SUBST([REPLACE_CLOSE])
|
||||
REPLACE_FCHDIR=0; AC_SUBST([REPLACE_FCHDIR])
|
||||
REPLACE_GETCWD=0; AC_SUBST([REPLACE_GETCWD])
|
||||
REPLACE_GETPAGESIZE=0; AC_SUBST([REPLACE_GETPAGESIZE])
|
||||
REPLACE_LCHOWN=0; AC_SUBST([REPLACE_LCHOWN])
|
||||
REPLACE_LSEEK=0; AC_SUBST([REPLACE_LSEEK])
|
||||
REPLACE_WRITE=0; AC_SUBST([REPLACE_WRITE])
|
||||
UNISTD_H_HAVE_WINSOCK2_H=0; AC_SUBST([UNISTD_H_HAVE_WINSOCK2_H])
|
||||
])
|
||||
25
m4/wchar.m4
25
m4/wchar.m4
|
|
@ -1,13 +1,13 @@
|
|||
dnl A placeholder for ISO C99 <wchar.h>, for platforms that have issues.
|
||||
|
||||
dnl Copyright (C) 2007 Free Software Foundation, Inc.
|
||||
dnl Copyright (C) 2007-2008 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
dnl with or without modifications, as long as this notice is preserved.
|
||||
|
||||
dnl Written by Eric Blake.
|
||||
|
||||
# wchar.m4 serial 4
|
||||
# wchar.m4 serial 6
|
||||
|
||||
AC_DEFUN([gl_WCHAR_H],
|
||||
[
|
||||
|
|
@ -18,7 +18,16 @@ AC_DEFUN([gl_WCHAR_H],
|
|||
wchar_t w;]],
|
||||
[gl_cv_header_wchar_h_standalone=yes],
|
||||
[gl_cv_header_wchar_h_standalone=no])])
|
||||
if test $gl_cv_header_wchar_h_standalone != yes; then
|
||||
|
||||
AC_REQUIRE([gt_TYPE_WINT_T])
|
||||
if test $gt_cv_c_wint_t = yes; then
|
||||
HAVE_WINT_T=1
|
||||
else
|
||||
HAVE_WINT_T=0
|
||||
fi
|
||||
AC_SUBST([HAVE_WINT_T])
|
||||
|
||||
if test $gl_cv_header_wchar_h_standalone != yes || test $gt_cv_c_wint_t != yes; then
|
||||
WCHAR_H=wchar.h
|
||||
fi
|
||||
|
||||
|
|
@ -36,6 +45,13 @@ wchar_t w;]],
|
|||
gl_CHECK_NEXT_HEADERS([wchar.h])
|
||||
])
|
||||
|
||||
dnl Unconditionally enables the replacement of <wchar.h>.
|
||||
AC_DEFUN([gl_REPLACE_WCHAR_H],
|
||||
[
|
||||
AC_REQUIRE([gl_WCHAR_H_DEFAULTS])
|
||||
WCHAR_H=wchar.h
|
||||
])
|
||||
|
||||
AC_DEFUN([gl_WCHAR_MODULE_INDICATOR],
|
||||
[
|
||||
dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
|
||||
|
|
@ -49,6 +65,5 @@ AC_DEFUN([gl_WCHAR_H_DEFAULTS],
|
|||
dnl Assume proper GNU behavior unless another module says otherwise.
|
||||
HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH])
|
||||
REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH])
|
||||
WCHAR_H=
|
||||
AC_SUBST([WCHAR_H])
|
||||
WCHAR_H=''; AC_SUBST([WCHAR_H])
|
||||
])
|
||||
|
|
|
|||
28
m4/wint_t.m4
Normal file
28
m4/wint_t.m4
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
# wint_t.m4 serial 2 (gettext-0.17)
|
||||
dnl Copyright (C) 2003, 2007 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
dnl with or without modifications, as long as this notice is preserved.
|
||||
|
||||
dnl From Bruno Haible.
|
||||
dnl Test whether <wchar.h> has the 'wint_t' type.
|
||||
dnl Prerequisite: AC_PROG_CC
|
||||
|
||||
AC_DEFUN([gt_TYPE_WINT_T],
|
||||
[
|
||||
AC_CACHE_CHECK([for wint_t], gt_cv_c_wint_t,
|
||||
[AC_TRY_COMPILE([
|
||||
/* Tru64 with Desktop Toolkit C has a bug: <stdio.h> must be included before
|
||||
<wchar.h>.
|
||||
BSD/OS 4.0.1 has a bug: <stddef.h>, <stdio.h> and <time.h> must be included
|
||||
before <wchar.h>. */
|
||||
#include <stddef.h>
|
||||
#include <stdio.h>
|
||||
#include <time.h>
|
||||
#include <wchar.h>
|
||||
wint_t foo = (wchar_t)'\0';], ,
|
||||
gt_cv_c_wint_t=yes, gt_cv_c_wint_t=no)])
|
||||
if test $gt_cv_c_wint_t = yes; then
|
||||
AC_DEFINE(HAVE_WINT_T, 1, [Define if you have the 'wint_t' type.])
|
||||
fi
|
||||
])
|
||||
20
m4/write.m4
Normal file
20
m4/write.m4
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
# write.m4 serial 1
|
||||
dnl Copyright (C) 2008 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
dnl with or without modifications, as long as this notice is preserved.
|
||||
|
||||
AC_DEFUN([gl_FUNC_WRITE],
|
||||
[
|
||||
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
|
||||
dnl This ifdef is just an optimization, to avoid performing a configure
|
||||
dnl check whose result is not used. It does not make the test of
|
||||
dnl GNULIB_UNISTD_H_SIGPIPE or GNULIB_SIGPIPE redundant.
|
||||
m4_ifdef([gl_SIGNAL_SIGPIPE], [
|
||||
gl_SIGNAL_SIGPIPE
|
||||
if test $gl_cv_header_signal_h_SIGPIPE != yes; then
|
||||
REPLACE_WRITE=1
|
||||
AC_LIBOBJ([write])
|
||||
fi
|
||||
])
|
||||
])
|
||||
|
|
@ -22,8 +22,8 @@
|
|||
AUTOMAKE_OPTIONS = gnu
|
||||
|
||||
# These should be installed and distributed.
|
||||
ice9_debugging_sources = breakpoints.scm example-fns.scm \
|
||||
ice-9-debugger-extensions.scm load-hooks.scm \
|
||||
ice9_debugging_sources = example-fns.scm \
|
||||
ice-9-debugger-extensions.scm \
|
||||
steps.scm trace.scm traps.scm trc.scm
|
||||
|
||||
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
(define-module (ice-9 gds-client)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (oop goops describe)
|
||||
#:use-module (ice-9 debugging breakpoints)
|
||||
#:use-module (ice-9 debugging trace)
|
||||
#:use-module (ice-9 debugging traps)
|
||||
#:use-module (ice-9 debugging trc)
|
||||
|
|
@ -12,7 +11,6 @@
|
|||
#:use-module (ice-9 string-fun)
|
||||
#:export (gds-debug-trap
|
||||
run-utility
|
||||
set-gds-breakpoints
|
||||
gds-accept-input))
|
||||
|
||||
(cond ((string>=? (version) "1.7")
|
||||
|
|
@ -383,7 +381,6 @@ Thanks!\n\n"
|
|||
;; Another complete expression read; add
|
||||
;; it to the list.
|
||||
(begin
|
||||
(for-each-breakpoint setup-after-read x)
|
||||
(if (and (pair? x)
|
||||
(memq 'debug flags))
|
||||
(install-trap (make <source-trap>
|
||||
|
|
@ -400,11 +397,7 @@ Thanks!\n\n"
|
|||
(display " to evaluate\n")
|
||||
(apply display-error #f
|
||||
(current-output-port) args)))
|
||||
("error-in-read"))))))))
|
||||
(if (string? port-name)
|
||||
(without-traps
|
||||
(lambda ()
|
||||
(for-each-breakpoint setup-after-eval port-name)))))
|
||||
("error-in-read")))))))))
|
||||
(cdr protocol)))
|
||||
|
||||
((complete)
|
||||
|
|
@ -441,83 +434,9 @@ Thanks!\n\n"
|
|||
(gds-debug-trap last-lazy-trap-context)
|
||||
(error "There is no stack available to show")))
|
||||
|
||||
((set-breakpoint)
|
||||
;; Create or update a breakpoint object according to the
|
||||
;; definition. If the target code is already loaded, note that
|
||||
;; this may immediately install a trap.
|
||||
(let* ((num (cadr protocol))
|
||||
(def (caddr protocol))
|
||||
(behaviour (case (list-ref def 0)
|
||||
((debug) gds-debug-trap)
|
||||
((trace) gds-trace-trap)
|
||||
((trace-subtree) gds-trace-subtree)
|
||||
(else (error "Unsupported behaviour:"
|
||||
(list-ref def 0)))))
|
||||
(bp (hash-ref breakpoints num)))
|
||||
(trc 'existing-bp bp)
|
||||
(if bp
|
||||
(update-breakpoint bp (list-ref def 3))
|
||||
(begin
|
||||
(set! bp
|
||||
(case (list-ref def 1)
|
||||
((in)
|
||||
(break-in (string->symbol (list-ref def 3))
|
||||
(list-ref def 2)
|
||||
#:behaviour behaviour))
|
||||
((at)
|
||||
(break-at (list-ref def 2)
|
||||
(car (list-ref def 3))
|
||||
(cdr (list-ref def 3))
|
||||
#:behaviour behaviour))
|
||||
(else
|
||||
(error "Unsupported breakpoint type:"
|
||||
(list-ref def 1)))))
|
||||
;; Install an observer that will tell the frontend about
|
||||
;; future changes in this breakpoint's status.
|
||||
(slot-set! bp 'observer
|
||||
(lambda ()
|
||||
(write-form `(breakpoint
|
||||
,num
|
||||
,@(map trap-description
|
||||
(slot-ref bp 'traps))))))
|
||||
;; Add this to the breakpoint hash, and return the
|
||||
;; breakpoint number and status to the front end.
|
||||
(hash-set! breakpoints num bp)))
|
||||
;; Call the breakpoint's observer now.
|
||||
((slot-ref bp 'observer))))
|
||||
|
||||
((delete-breakpoint)
|
||||
(let* ((num (cadr protocol))
|
||||
(bp (hash-ref breakpoints num)))
|
||||
(if bp
|
||||
(begin
|
||||
(hash-remove! breakpoints num)
|
||||
(delete-breakpoint bp)))))
|
||||
|
||||
;;; ((describe-breakpoints)
|
||||
;;; ;; Describe all breakpoints.
|
||||
;;; (let ((desc
|
||||
;;; (with-output-to-string
|
||||
;;; (lambda ()
|
||||
;;; (hash-fold (lambda (num bp acc)
|
||||
;;; (format #t
|
||||
;;; "Breakpoint ~a ~a (~a):\n"
|
||||
;;; (class-name (class-of bp))
|
||||
;;; num
|
||||
;;; (slot-ref bp 'status))
|
||||
;;; (for-each (lambda (trap)
|
||||
;;; (write (trap-description trap))
|
||||
;;; (newline))
|
||||
;;; (slot-ref bp 'traps)))
|
||||
;;; #f
|
||||
;;; breakpoints)))))
|
||||
;;; (write-form (list 'info-result desc))))
|
||||
|
||||
(else
|
||||
(error "Unexpected protocol:" protocol))))
|
||||
|
||||
(define breakpoints (make-hash-table 11))
|
||||
|
||||
(define (resolve-module-from-root name)
|
||||
(save-module-excursion
|
||||
(lambda ()
|
||||
|
|
@ -591,18 +510,13 @@ Thanks!\n\n"
|
|||
(apply throw key args))
|
||||
|
||||
(define (run-utility)
|
||||
(set-gds-breakpoints)
|
||||
(connect-to-gds)
|
||||
(write (getpid))
|
||||
(newline)
|
||||
(force-output)
|
||||
(named-module-use! '(guile-user) '(ice-9 session))
|
||||
(gds-accept-input #f))
|
||||
|
||||
(define (set-gds-breakpoints)
|
||||
(connect-to-gds)
|
||||
(write-form '(get-breakpoints))
|
||||
(gds-accept-input #t))
|
||||
|
||||
(define-method (trap-description (trap <trap>))
|
||||
(let loop ((description (list (class-name (class-of trap))))
|
||||
(next 'installed?))
|
||||
|
|
|
|||
|
|
@ -1403,7 +1403,7 @@
|
|||
(define (priv:string->date date index format-string str-len port template-string)
|
||||
(define (skip-until port skipper)
|
||||
(let ((ch (peek-char port)))
|
||||
(if (eof-object? port)
|
||||
(if (eof-object? ch)
|
||||
(priv:time-error 'string->date 'bad-date-format-string template-string)
|
||||
(if (not (skipper ch))
|
||||
(begin (read-char port) (skip-until port skipper))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; srfi-34.scm --- Exception handling for programs
|
||||
|
||||
;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2003, 2006, 2008 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
|
||||
|
|
@ -40,7 +40,7 @@
|
|||
procedure that accepts one argument. It is installed as the current
|
||||
exception handler for the dynamic extent (as determined by
|
||||
dynamic-wind) of the invocation of THUNK."
|
||||
(lazy-catch throw-key
|
||||
(with-throw-handler throw-key
|
||||
thunk
|
||||
(lambda (key obj)
|
||||
(handler obj))))
|
||||
|
|
|
|||
|
|
@ -13,11 +13,9 @@ You can reference the file `lib.scm' from your own code as the module
|
|||
function explaining what's going on.
|
||||
|
||||
Please write more Guile tests, and send them to bug-guile@gnu.org.
|
||||
(Note that you must be subscribed to this list first, in order to
|
||||
successfully send a report to it.) We'll merge them into the
|
||||
distribution. All test suites must be licensed for our use under the
|
||||
GPL, but I don't think I'm going to collect assignment papers for
|
||||
them.
|
||||
We'll merge them into the distribution. All test suites must be
|
||||
licensed for our use under the GPL, but I don't think I'm going to
|
||||
collect assignment papers for them.
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
18
test-suite/standalone/.gitignore
vendored
18
test-suite/standalone/.gitignore
vendored
|
|
@ -1,7 +1,11 @@
|
|||
test-conversion
|
||||
test-gh
|
||||
test-list
|
||||
test-num2integral
|
||||
test-round
|
||||
test-unwind
|
||||
test-with-guile-module
|
||||
/test-conversion
|
||||
/test-gh
|
||||
/test-list
|
||||
/test-num2integral
|
||||
/test-round
|
||||
/test-unwind
|
||||
/test-with-guile-module
|
||||
/test-use-srfi
|
||||
/test-scm-with-guile
|
||||
/test-scm-c-read
|
||||
/test-fast-slot-ref
|
||||
|
|
|
|||
|
|
@ -103,10 +103,21 @@ test_conversion_LDADD = ${top_builddir}/libguile/libguile.la
|
|||
check_PROGRAMS += test-conversion
|
||||
TESTS += test-conversion
|
||||
|
||||
# test-fast-slot-ref
|
||||
check_SCRIPTS += test-fast-slot-ref
|
||||
TESTS += test-fast-slot-ref
|
||||
|
||||
# test-use-srfi
|
||||
check_SCRIPTS += test-use-srfi
|
||||
TESTS += test-use-srfi
|
||||
|
||||
# test-scm-c-read
|
||||
test_scm_c_read_SOURCES = test-scm-c-read.c
|
||||
test_scm_c_read_CFLAGS = ${test_cflags}
|
||||
test_scm_c_read_LDADD = ${top_builddir}/libguile/libguile.la
|
||||
check_PROGRAMS += test-scm-c-read
|
||||
TESTS += test-scm-c-read
|
||||
|
||||
if BUILD_PTHREAD_SUPPORT
|
||||
|
||||
# test-with-guile-module
|
||||
|
|
@ -115,9 +126,14 @@ test_with_guile_module_LDADD = ${top_builddir}/libguile/libguile.la
|
|||
check_PROGRAMS += test-with-guile-module
|
||||
TESTS += test-with-guile-module
|
||||
|
||||
test_scm_with_guile_CFLAGS = ${test_cflags}
|
||||
test_scm_with_guile_LDADD = ${top_builddir}/libguile/libguile.la
|
||||
check_PROGRAMS += test-scm-with-guile
|
||||
TESTS += test-scm-with-guile
|
||||
|
||||
else
|
||||
|
||||
EXTRA_DIST += test-with-guile-module.c
|
||||
EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c
|
||||
|
||||
endif
|
||||
|
||||
|
|
|
|||
39
test-suite/standalone/test-fast-slot-ref.in
Normal file
39
test-suite/standalone/test-fast-slot-ref.in
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
#!/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 for %fast-slot-ref, which was previously implemented such that
|
||||
# an out-of-range slot index could escape being properly detected, and
|
||||
# could then cause a segmentation fault.
|
||||
#
|
||||
# Prior to the change in this commit to goops.c, the following
|
||||
# sequence reliably causes a segmentation fault on my GNU/Linux when
|
||||
# executing the (%fast-slot-ref i 3) line. For reasons as yet
|
||||
# unknown, it does not cause a segmentation fault if the same code is
|
||||
# loaded as a script; that is why we run it here using "guile -q <<EOF".
|
||||
exec guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm >/dev/null 2>&1 <<EOF
|
||||
(use-modules (oop goops))
|
||||
(define-module (oop goops))
|
||||
(define-class <c> () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3))
|
||||
(define i (make <c>))
|
||||
(%fast-slot-ref i 1)
|
||||
(%fast-slot-ref i 0)
|
||||
(%fast-slot-ref i 3)
|
||||
(%fast-slot-ref i -1)
|
||||
(%fast-slot-ref i 2)
|
||||
(exit 0)
|
||||
EOF
|
||||
130
test-suite/standalone/test-scm-c-read.c
Normal file
130
test-suite/standalone/test-scm-c-read.c
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
/* Copyright (C) 2008 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
|
||||
*/
|
||||
|
||||
/* Exercise `scm_c_read ()' and the port type API. Verify assumptions that
|
||||
can be made by port type implementations. */
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <libguile.h>
|
||||
#include <assert.h>
|
||||
|
||||
|
||||
|
||||
/* Size of our port's internal buffer. */
|
||||
#define PORT_BUFFER_SIZE 1024
|
||||
|
||||
/* Return a new port of type PORT_TYPE. */
|
||||
static inline SCM
|
||||
make_port (scm_t_bits port_type)
|
||||
{
|
||||
SCM port;
|
||||
char *c_buffer;
|
||||
scm_t_port *c_port;
|
||||
|
||||
c_buffer = scm_gc_calloc (PORT_BUFFER_SIZE, "custom-port-buffer");
|
||||
|
||||
port = scm_new_port_table_entry (port_type);
|
||||
|
||||
/* Associate C_BUFFER with PORT, for test purposes. */
|
||||
SCM_SETSTREAM (port, (scm_t_bits) c_buffer);
|
||||
|
||||
/* Use C_BUFFER as PORT's internal buffer. */
|
||||
c_port = SCM_PTAB_ENTRY (port);
|
||||
c_port->read_pos = c_port->read_buf = (unsigned char *) c_buffer;
|
||||
c_port->read_end = (unsigned char *) c_buffer + PORT_BUFFER_SIZE;
|
||||
c_port->read_buf_size = PORT_BUFFER_SIZE;
|
||||
|
||||
/* Mark PORT as open and readable. */
|
||||
SCM_SET_CELL_TYPE (port, port_type | SCM_OPN | SCM_RDNG);
|
||||
|
||||
return port;
|
||||
}
|
||||
|
||||
/* Read one byte from PORT. */
|
||||
static int
|
||||
fill_input (SCM port)
|
||||
{
|
||||
int result;
|
||||
scm_t_port *c_port = SCM_PTAB_ENTRY (port);
|
||||
|
||||
/* Make sure that C_PORT's internal buffer wasn't changed behind our back.
|
||||
See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00042.html
|
||||
for an example where this assumption matters. */
|
||||
assert (c_port->read_buf == (unsigned char *) SCM_STREAM (port));
|
||||
assert (c_port->read_buf_size == PORT_BUFFER_SIZE);
|
||||
|
||||
if (c_port->read_pos >= c_port->read_end)
|
||||
result = EOF;
|
||||
else
|
||||
result = (int) *c_port->read_pos++;
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/* Return true (non-zero) if BUF contains only zeros. */
|
||||
static inline int
|
||||
zeroed_buffer_p (const char *buf, size_t len)
|
||||
{
|
||||
size_t i;
|
||||
|
||||
for (i = 0; i < len; i++)
|
||||
if (buf[i] != 0)
|
||||
return 0;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Run the test. */
|
||||
static void *
|
||||
do_start (void *arg)
|
||||
{
|
||||
SCM port;
|
||||
scm_t_bits port_type;
|
||||
char buffer[PORT_BUFFER_SIZE + (PORT_BUFFER_SIZE / 2)];
|
||||
size_t read, last_read;
|
||||
|
||||
port_type = scm_make_port_type ("custom-input-port", fill_input, NULL);
|
||||
port = make_port (port_type);
|
||||
|
||||
read = 0;
|
||||
do
|
||||
{
|
||||
last_read = scm_c_read (port, &buffer[read], 123);
|
||||
assert (last_read <= 123);
|
||||
assert (zeroed_buffer_p (&buffer[read], last_read));
|
||||
|
||||
read += last_read;
|
||||
}
|
||||
while (last_read > 0 && read < sizeof (buffer));
|
||||
|
||||
/* We shouldn't be able to read more than what's in PORT's buffer. */
|
||||
assert (read == PORT_BUFFER_SIZE);
|
||||
|
||||
return NULL;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
main (int argc, char *argv[])
|
||||
{
|
||||
scm_with_guile (do_start, NULL);
|
||||
|
||||
return 0;
|
||||
}
|
||||
66
test-suite/standalone/test-scm-with-guile.c
Normal file
66
test-suite/standalone/test-scm-with-guile.c
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
/* Copyright (C) 2008 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 whether `scm_with_guile ()' can be called several times from a given
|
||||
thread, but from a different stack depth. Up to 1.8.5, `scm_with_guile
|
||||
()' would not update the thread's `base' field, which would then confuse
|
||||
the GC.
|
||||
|
||||
See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00037.html
|
||||
for a detailed report. */
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <libguile.h>
|
||||
|
||||
static void *
|
||||
entry_point (void *arg)
|
||||
{
|
||||
/* Invoke the GC. If `THREAD->base' is incorrect, then Guile will just
|
||||
segfault somewhere in `scm_mark_locations ()'. */
|
||||
scm_gc ();
|
||||
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static void
|
||||
go_deeper_into_the_stack (unsigned level)
|
||||
{
|
||||
/* The assumption is that the compiler is not smart enough to optimize this
|
||||
out. */
|
||||
if (level > 0)
|
||||
go_deeper_into_the_stack (level - 1);
|
||||
else
|
||||
scm_with_guile (entry_point, NULL);
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
main (int argc, char *argv[])
|
||||
{
|
||||
/* Invoke `scm_with_guile ()' from someplace deep into the stack. */
|
||||
go_deeper_into_the_stack (100);
|
||||
|
||||
/* Invoke it from much higher into the stack. This time, Guile is expected
|
||||
to update the `base' field of the current thread. */
|
||||
scm_with_guile (entry_point, NULL);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -19,7 +19,7 @@
|
|||
|
||||
# Test that two srfi numbers on the command line work.
|
||||
#
|
||||
guile -q --use-srfi=1,10 >/dev/null <<EOF
|
||||
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1,10 >/dev/null <<EOF
|
||||
(if (and (defined? 'partition)
|
||||
(defined? 'define-reader-ctor))
|
||||
(exit 0) ;; good
|
||||
|
|
@ -38,7 +38,7 @@ fi
|
|||
# `top-repl' the core bindings got ahead of anything --use-srfi gave.
|
||||
#
|
||||
|
||||
guile -q --use-srfi=1 >/dev/null <<EOF
|
||||
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1 >/dev/null <<EOF
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(iota 2 3 4))
|
||||
|
|
@ -56,7 +56,7 @@ fi
|
|||
# exercises duplicates handling in `top-repl' versus `use-srfis' (in
|
||||
# boot-9.scm).
|
||||
#
|
||||
guile -q --use-srfi=17 >/dev/null <<EOF
|
||||
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=17 >/dev/null <<EOF
|
||||
(if (procedure-with-setter? car)
|
||||
(exit 0) ;; good
|
||||
(exit 1)) ;; bad
|
||||
|
|
@ -62,6 +62,209 @@
|
|||
(pass-if (= 0 (hashq #f 1)))
|
||||
(pass-if (= 0 (hashq noop 1))))
|
||||
|
||||
;;;
|
||||
;;; make-hash-table
|
||||
;;;
|
||||
|
||||
(with-test-prefix
|
||||
"make-hash-table, hash-table?"
|
||||
(pass-if-exception "make-hash-table -1" exception:out-of-range
|
||||
(make-hash-table -1))
|
||||
(pass-if (hash-table? (make-hash-table 0))) ;; default
|
||||
(pass-if (not (hash-table? 'not-a-hash-table)))
|
||||
(pass-if (equal? "#<hash-table 0/113>"
|
||||
(with-output-to-string
|
||||
(lambda () (write (make-hash-table 100)))))))
|
||||
|
||||
;;;
|
||||
;;; usual set and reference
|
||||
;;;
|
||||
|
||||
(with-test-prefix
|
||||
"hash-set and hash-ref"
|
||||
|
||||
;; auto-resizing
|
||||
(pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31
|
||||
(hash-set! table 'one 1)
|
||||
(hash-set! table 'two #t)
|
||||
(hash-set! table 'three #t)
|
||||
(hash-set! table 'four #t)
|
||||
(hash-set! table 'five #t)
|
||||
(hash-set! table 'six #t)
|
||||
(hash-set! table 'seven #t)
|
||||
(hash-set! table 'eight #t)
|
||||
(hash-set! table 'nine 9)
|
||||
(hash-set! table 'ten #t)
|
||||
(hash-set! table 'eleven #t)
|
||||
(hash-set! table 'twelve #t)
|
||||
(hash-set! table 'thirteen #t)
|
||||
(hash-set! table 'fourteen #t)
|
||||
(hash-set! table 'fifteen #t)
|
||||
(hash-set! table 'sixteen #t)
|
||||
(hash-set! table 'seventeen #t)
|
||||
(hash-set! table 18 #t)
|
||||
(hash-set! table 19 #t)
|
||||
(hash-set! table 20 #t)
|
||||
(hash-set! table 21 #t)
|
||||
(hash-set! table 22 #t)
|
||||
(hash-set! table 23 #t)
|
||||
(hash-set! table 24 #t)
|
||||
(hash-set! table 25 #t)
|
||||
(hash-set! table 26 #t)
|
||||
(hash-set! table 27 #t)
|
||||
(hash-set! table 28 #t)
|
||||
(hash-set! table 29 #t)
|
||||
(hash-set! table 30 'thirty)
|
||||
(hash-set! table 31 #t)
|
||||
(hash-set! table 32 #t)
|
||||
(hash-set! table 33 'thirty-three)
|
||||
(hash-set! table 34 #t)
|
||||
(hash-set! table 35 #t)
|
||||
(hash-set! table 'foo 'bar)
|
||||
(and (equal? 1 (hash-ref table 'one))
|
||||
(equal? 9 (hash-ref table 'nine))
|
||||
(equal? 'thirty (hash-ref table 30))
|
||||
(equal? 'thirty-three (hash-ref table 33))
|
||||
(equal? 'bar (hash-ref table 'foo))
|
||||
(equal? "#<hash-table 36/61>"
|
||||
(with-output-to-string (lambda () (write table)))))))
|
||||
|
||||
;; 1 and 1 are equal? and eqv? and eq?
|
||||
(pass-if (equal? 'foo
|
||||
(let ((table (make-hash-table)))
|
||||
(hash-set! table 1 'foo)
|
||||
(hash-ref table 1))))
|
||||
(pass-if (equal? 'foo
|
||||
(let ((table (make-hash-table)))
|
||||
(hashv-set! table 1 'foo)
|
||||
(hashv-ref table 1))))
|
||||
(pass-if (equal? 'foo
|
||||
(let ((table (make-hash-table)))
|
||||
(hashq-set! table 1 'foo)
|
||||
(hashq-ref table 1))))
|
||||
|
||||
;; 1/2 and 2/4 are equal? and eqv? but not eq?
|
||||
(pass-if (equal? 'foo
|
||||
(let ((table (make-hash-table)))
|
||||
(hash-set! table 1/2 'foo)
|
||||
(hash-ref table 2/4))))
|
||||
(pass-if (equal? 'foo
|
||||
(let ((table (make-hash-table)))
|
||||
(hashv-set! table 1/2 'foo)
|
||||
(hashv-ref table 2/4))))
|
||||
(pass-if (equal? #f
|
||||
(let ((table (make-hash-table)))
|
||||
(hashq-set! table 1/2 'foo)
|
||||
(hashq-ref table 2/4))))
|
||||
|
||||
;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
|
||||
(pass-if (equal? 'foo
|
||||
(let ((table (make-hash-table)))
|
||||
(hash-set! table (list 1 2) 'foo)
|
||||
(hash-ref table (list 1 2)))))
|
||||
(pass-if (equal? #f
|
||||
(let ((table (make-hash-table)))
|
||||
(hashv-set! table (list 1 2) 'foo)
|
||||
(hashv-ref table (list 1 2)))))
|
||||
(pass-if (equal? #f
|
||||
(let ((table (make-hash-table)))
|
||||
(hashq-set! table (list 1 2) 'foo)
|
||||
(hashq-ref table (list 1 2)))))
|
||||
|
||||
;; ref default argument
|
||||
(pass-if (equal? 'bar
|
||||
(let ((table (make-hash-table)))
|
||||
(hash-ref table 'foo 'bar))))
|
||||
(pass-if (equal? 'bar
|
||||
(let ((table (make-hash-table)))
|
||||
(hashv-ref table 'foo 'bar))))
|
||||
(pass-if (equal? 'bar
|
||||
(let ((table (make-hash-table)))
|
||||
(hashq-ref table 'foo 'bar))))
|
||||
(pass-if (equal? 'bar
|
||||
(let ((table (make-hash-table)))
|
||||
(hashx-ref hash equal? table 'foo 'bar))))
|
||||
|
||||
;; wrong type argument
|
||||
(pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg
|
||||
(hash-ref 'not-a-table 'key))
|
||||
)
|
||||
|
||||
;;;
|
||||
;;; hashx
|
||||
;;;
|
||||
|
||||
(with-test-prefix
|
||||
"auto-resizing hashx"
|
||||
;; auto-resizing
|
||||
(let ((table (make-hash-table 1))) ;;actually makes size 31
|
||||
(hashx-set! hash assoc table 1/2 'equal)
|
||||
(hashx-set! hash assoc table 1/3 'equal)
|
||||
(hashx-set! hash assoc table 4 'equal)
|
||||
(hashx-set! hash assoc table 1/5 'equal)
|
||||
(hashx-set! hash assoc table 1/6 'equal)
|
||||
(hashx-set! hash assoc table 7 'equal)
|
||||
(hashx-set! hash assoc table 1/8 'equal)
|
||||
(hashx-set! hash assoc table 1/9 'equal)
|
||||
(hashx-set! hash assoc table 10 'equal)
|
||||
(hashx-set! hash assoc table 1/11 'equal)
|
||||
(hashx-set! hash assoc table 1/12 'equal)
|
||||
(hashx-set! hash assoc table 13 'equal)
|
||||
(hashx-set! hash assoc table 1/14 'equal)
|
||||
(hashx-set! hash assoc table 1/15 'equal)
|
||||
(hashx-set! hash assoc table 16 'equal)
|
||||
(hashx-set! hash assoc table 1/17 'equal)
|
||||
(hashx-set! hash assoc table 1/18 'equal)
|
||||
(hashx-set! hash assoc table 19 'equal)
|
||||
(hashx-set! hash assoc table 1/20 'equal)
|
||||
(hashx-set! hash assoc table 1/21 'equal)
|
||||
(hashx-set! hash assoc table 22 'equal)
|
||||
(hashx-set! hash assoc table 1/23 'equal)
|
||||
(hashx-set! hash assoc table 1/24 'equal)
|
||||
(hashx-set! hash assoc table 25 'equal)
|
||||
(hashx-set! hash assoc table 1/26 'equal)
|
||||
(hashx-set! hash assoc table 1/27 'equal)
|
||||
(hashx-set! hash assoc table 28 'equal)
|
||||
(hashx-set! hash assoc table 1/29 'equal)
|
||||
(hashx-set! hash assoc table 1/30 'equal)
|
||||
(hashx-set! hash assoc table 31 'equal)
|
||||
(hashx-set! hash assoc table 1/32 'equal)
|
||||
(hashx-set! hash assoc table 1/33 'equal)
|
||||
(hashx-set! hash assoc table 34 'equal)
|
||||
(pass-if (equal? 'equal (hash-ref table 2/4)))
|
||||
(pass-if (equal? 'equal (hash-ref table 2/6)))
|
||||
(pass-if (equal? 'equal (hash-ref table 4)))
|
||||
(pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
|
||||
(pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
|
||||
(pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
|
||||
(pass-if (equal? "#<hash-table 33/61>"
|
||||
(with-output-to-string (lambda () (write table)))))))
|
||||
|
||||
(with-test-prefix
|
||||
"hashx"
|
||||
(pass-if (let ((table (make-hash-table)))
|
||||
(hashx-set! (lambda (k v) 1)
|
||||
(lambda (k al) (assoc 'foo al))
|
||||
table 'foo 'bar)
|
||||
(equal?
|
||||
'bar (hashx-ref (lambda (k v) 1)
|
||||
(lambda (k al) (assoc 'foo al))
|
||||
table 'baz))))
|
||||
(pass-if (let ((table (make-hash-table 31)))
|
||||
(hashx-set! (lambda (k v) 1) assoc table 'foo 'bar)
|
||||
(equal? #f
|
||||
(hashx-ref (lambda (k v) 2) assoc table 'foo))))
|
||||
(pass-if (let ((table (make-hash-table)))
|
||||
(hashx-set! hash assoc table 'foo 'bar)
|
||||
(equal? #f
|
||||
(hashx-ref hash (lambda (k al) #f) table 'foo))))
|
||||
(pass-if-exception
|
||||
"hashx-set! (lambda (k s) 1) equal? table 'foo 'bar"
|
||||
exception:wrong-type-arg ;; there must be a better exception than that...
|
||||
(hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
|
||||
)
|
||||
|
||||
|
||||
;;;
|
||||
;;; hashx-remove!
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -88,7 +88,14 @@
|
|||
|
||||
(pass-if "CR recognized as a token delimiter"
|
||||
;; In 1.8.3, character 0x0d was not recognized as a delimiter.
|
||||
(equal? (read-string "one\x0dtwo") 'one)))
|
||||
(equal? (read-string "one\x0dtwo") 'one))
|
||||
|
||||
(pass-if "returned strings are mutable"
|
||||
;; Per R5RS Section 3.4, "Storage Model", `read' is supposed to return
|
||||
;; mutable objects.
|
||||
(let ((str (with-input-from-string "\"hello, world\"" read)))
|
||||
(string-set! str 0 #\H)
|
||||
(string=? str "Hello, world"))))
|
||||
|
||||
|
||||
(pass-if-exception "radix passed to number->string can't be zero"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
|
||||
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008 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
|
||||
|
|
@ -166,6 +166,14 @@ incomplete numerical tower implementation.)"
|
|||
0)))
|
||||
(date->time-utc
|
||||
(make-date 0 0 0 0 9 12 2006 0))))
|
||||
|
||||
(pass-if "string->date works on Sunday"
|
||||
;; `string->date' never rests!
|
||||
(let* ((str "Sun, 05 Jun 2005 18:33:00 +0200")
|
||||
(date (string->date str "~a, ~d ~b ~Y ~H:~M:~S ~z")))
|
||||
(equal? "Sun Jun 05 18:33:00+0200 2005"
|
||||
(date->string date))))
|
||||
|
||||
;; check time comparison procedures
|
||||
(let* ((time1 (make-time time-monotonic 0 0))
|
||||
(time2 (make-time time-monotonic 0 0))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2003, 2004, 2006, 2008 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
|
||||
|
|
@ -161,4 +161,24 @@
|
|||
""
|
||||
'(b . 23)))
|
||||
|
||||
)
|
||||
(pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
|
||||
;; In Guile 1.8.5 and earlier, unwinders would be called before
|
||||
;; the exception handler, which reads "The handler is called in
|
||||
;; the dynamic environment of the call to `raise'".
|
||||
(call/cc
|
||||
(lambda (return)
|
||||
(let ((inside? #f))
|
||||
(with-exception-handler
|
||||
(lambda (c)
|
||||
;; This handler must be called before the unwinder below.
|
||||
(return inside?))
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! inside? #t))
|
||||
(lambda ()
|
||||
(raise 'some-exception))
|
||||
(lambda ()
|
||||
;; This unwinder should not be executed before the
|
||||
;; handler is called.
|
||||
(set! inside? #f))))))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; srfi-39.test --- -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2004, 2005, 2006, 2008 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
|
||||
|
|
@ -19,7 +19,10 @@
|
|||
|
||||
(define-module (test-srfi-39)
|
||||
#:use-module (test-suite lib)
|
||||
#:use-module (srfi srfi-39))
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-39)
|
||||
#:duplicates (last) ;; avoid warning about srfi-34 replacing `raise'
|
||||
)
|
||||
|
||||
(define a (make-parameter 3))
|
||||
(define b (make-parameter 4))
|
||||
|
|
@ -53,7 +56,19 @@
|
|||
(check c d 10 9)
|
||||
(parameterize ((c (a)) (d (b)))
|
||||
(and (check a b 0 1)
|
||||
(check c d 0 1)))))))
|
||||
(check c d 0 1))))))
|
||||
|
||||
(pass-if "SRFI-34"
|
||||
(let ((inside? (make-parameter #f)))
|
||||
(call/cc (lambda (return)
|
||||
(with-exception-handler
|
||||
(lambda (c)
|
||||
;; This handler should be called in the dynamic
|
||||
;; environment installed by `parameterize'.
|
||||
(return (inside?)))
|
||||
(lambda ()
|
||||
(parameterize ((inside? #t))
|
||||
(raise 'some-exception)))))))))
|
||||
|
||||
(let ()
|
||||
(define (test-ports param new-port new-port-2)
|
||||
|
|
|
|||
|
|
@ -160,19 +160,62 @@
|
|||
(eq? (char-ci>=? (integer->char 0) (integer->char 255))
|
||||
(string-ci>=? (string-ints 0) (string-ints 255)))))
|
||||
|
||||
;;
|
||||
;; string-ref
|
||||
;;
|
||||
|
||||
(with-test-prefix "string-ref"
|
||||
|
||||
(pass-if-exception "empty string"
|
||||
exception:out-of-range
|
||||
(string-ref "" 0))
|
||||
|
||||
(pass-if-exception "empty string and non-zero index"
|
||||
exception:out-of-range
|
||||
(string-ref "" 123))
|
||||
|
||||
(pass-if-exception "out of range"
|
||||
exception:out-of-range
|
||||
(string-ref "hello" 123))
|
||||
|
||||
(pass-if-exception "negative index"
|
||||
exception:out-of-range
|
||||
(string-ref "hello" -1))
|
||||
|
||||
(pass-if "regular string"
|
||||
(char=? (string-ref "GNU Guile" 4) #\G)))
|
||||
|
||||
;;
|
||||
;; string-set!
|
||||
;;
|
||||
|
||||
(with-test-prefix "string-set!"
|
||||
|
||||
(pass-if-exception "empty string"
|
||||
exception:out-of-range
|
||||
(string-set! (string-copy "") 0 #\x))
|
||||
|
||||
(pass-if-exception "empty string and non-zero index"
|
||||
exception:out-of-range
|
||||
(string-set! (string-copy "") 123 #\x))
|
||||
|
||||
(pass-if-exception "out of range"
|
||||
exception:out-of-range
|
||||
(string-set! (string-copy "hello") 123 #\x))
|
||||
|
||||
(pass-if-exception "negative index"
|
||||
exception:out-of-range
|
||||
(string-set! (string-copy "hello") -1 #\x))
|
||||
|
||||
(pass-if-exception "read-only string"
|
||||
exception:read-only-string
|
||||
(string-set! (substring/read-only "abc" 0) 1 #\space))
|
||||
|
||||
(pass-if-exception "literal string"
|
||||
exception:read-only-string
|
||||
(string-set! "an immutable string" 0 #\a)))
|
||||
(pass-if "regular string"
|
||||
(let ((s (string-copy "GNU guile")))
|
||||
(string-set! s 4 #\G)
|
||||
(char=? (string-ref s 4) #\G))))
|
||||
|
||||
|
||||
(with-test-prefix "string-split"
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue