mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts: lib/Makefile.am libguile/struct.c libguile/threads.c m4/gnulib-cache.m4 m4/gnulib-comp.m4
This commit is contained in:
Ludovic Courtès
commit
083f810fe9
70 changed files with 2074 additions and 1554 deletions
3
.gitignore
vendored
3
.gitignore
vendored
|
|
@ -71,3 +71,6 @@ guile-readline/guile-readline-config.h.in
|
|||
TAGS
|
||||
guile-1.8.pc
|
||||
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:
|
||||
|
|
|
|||
|
|
@ -37,7 +37,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
|
||||
|
||||
|
|
|
|||
32
NEWS
32
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:
|
||||
|
|
@ -56,6 +54,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,6 +63,12 @@ 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
|
||||
|
|
@ -78,6 +84,13 @@ available: Guile is now always configured in "maintainer mode".
|
|||
** 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)
|
||||
|
|
@ -230,7 +243,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):
|
||||
|
||||
|
|
@ -239,6 +251,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.
|
||||
|
|
@ -283,8 +305,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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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,6 +43,7 @@ EOF
|
|||
}
|
||||
|
||||
prefix="@prefix@"
|
||||
datarootdir="@datarootdir@"
|
||||
pkgdatadir="@datadir@/@PACKAGE@"
|
||||
guileversion="@GUILE_EFFECTIVE_VERSION@"
|
||||
default_scriptsdir=$pkgdatadir/$guileversion/scripts
|
||||
|
|
|
|||
|
|
@ -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,415 +0,0 @@
|
|||
;;;; (ice-9 debugging breakpoints) -- practical breakpoints
|
||||
|
||||
;;; Copyright (C) 2005 Neil Jerram
|
||||
;;;
|
||||
;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
;;; This module provides a practical interface for setting and
|
||||
;;; manipulating breakpoints.
|
||||
|
||||
(define-module (ice-9 debugging breakpoints)
|
||||
#:use-module (ice-9 debugger)
|
||||
#:use-module (ice-9 ls)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ice-9 debugging ice-9-debugger-extensions)
|
||||
#:use-module (ice-9 debugging traps)
|
||||
#:use-module (ice-9 debugging trc)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-13)
|
||||
#:export (break-in
|
||||
break-at
|
||||
default-breakpoint-behaviour
|
||||
delete-breakpoint
|
||||
for-each-breakpoint
|
||||
setup-before-load
|
||||
setup-after-load
|
||||
setup-after-read
|
||||
setup-after-eval))
|
||||
|
||||
;; If the running Guile does not provide before- and after- load hooks
|
||||
;; itself, install them using the (ice-9 debugging load-hooks) module.
|
||||
(or (defined? 'after-load-hook)
|
||||
(begin
|
||||
(use-modules (ice-9 debugging load-hooks))
|
||||
(install-load-hooks)))
|
||||
|
||||
;; Getter/setter for default breakpoint behaviour.
|
||||
(define default-breakpoint-behaviour
|
||||
(let ((behaviour debug-trap))
|
||||
(make-procedure-with-setter
|
||||
;; Getter: return current default behaviour.
|
||||
(lambda ()
|
||||
behaviour)
|
||||
;; Setter: set default behaviour to given procedure.
|
||||
(lambda (new-behaviour)
|
||||
(set! behaviour new-behaviour)))))
|
||||
|
||||
;; Base class for breakpoints. (We don't need to use GOOPS to
|
||||
;; represent breakpoints, but it's a nice way to describe a composite
|
||||
;; object.)
|
||||
(define-class <breakpoint> ()
|
||||
;; This breakpoint's trap options, which include its behaviour.
|
||||
(trap-options #:init-keyword #:trap-options)
|
||||
;; All the traps relating to this breakpoint.
|
||||
(traps #:init-value '())
|
||||
;; Observer. This is a procedure that is called when the breakpoint
|
||||
;; trap list changes.
|
||||
(observer #:init-value #f))
|
||||
|
||||
;; Noop base class definitions of all the possible setup methods.
|
||||
(define-method (setup-before-load (bp <breakpoint>) filename)
|
||||
*unspecified*)
|
||||
(define-method (setup-after-load (bp <breakpoint>) filename)
|
||||
*unspecified*)
|
||||
(define-method (setup-after-read (bp <breakpoint>) x)
|
||||
*unspecified*)
|
||||
(define-method (setup-after-eval (bp <breakpoint>) filename)
|
||||
*unspecified*)
|
||||
|
||||
;; Call the breakpoint's observer, if it has one.
|
||||
(define-method (call-observer (bp <breakpoint>))
|
||||
(cond ((slot-ref bp 'observer)
|
||||
=>
|
||||
(lambda (proc)
|
||||
(proc)))))
|
||||
|
||||
;; Delete a breakpoint.
|
||||
(define (delete-breakpoint bp)
|
||||
;; Remove this breakpoint from the global list.
|
||||
(set! breakpoints (delq! bp breakpoints))
|
||||
;; Uninstall and discard all its traps.
|
||||
(for-each uninstall-trap (slot-ref bp 'traps))
|
||||
(slot-set! bp 'traps '()))
|
||||
|
||||
;; Class for `break-in' breakpoints.
|
||||
(define-class <break-in> (<breakpoint>)
|
||||
;; The name of the procedure to break in.
|
||||
(procedure-name #:init-keyword #:procedure-name)
|
||||
;; The name of the module or file that the procedure is defined in.
|
||||
;; A module name is a list of symbols that exactly names the
|
||||
;; relevant module. A file name is a string, which can in fact be
|
||||
;; any substring of the relevant full file name.
|
||||
(module-or-file-name #:init-keyword #:module-or-file-name))
|
||||
|
||||
;; Class for `break-at' breakpoints.
|
||||
(define-class <break-at> (<breakpoint>)
|
||||
;; The name of the file to break in. This is a string, which can in
|
||||
;; fact be any substring of the relevant full file name.
|
||||
(file-name #:init-keyword #:file-name)
|
||||
;; Line and column number to break at.
|
||||
(line #:init-keyword #:line)
|
||||
(column #:init-keyword #:column))
|
||||
|
||||
;; Global list of non-deleted breakpoints.
|
||||
(define breakpoints '())
|
||||
|
||||
;; Add to the above list.
|
||||
(define-method (add-to-global-breakpoint-list (bp <breakpoint>))
|
||||
(set! breakpoints (append! breakpoints (list bp))))
|
||||
|
||||
;; break-in: create a `break-in' breakpoint.
|
||||
(define (break-in procedure-name . options)
|
||||
;; Sort out the optional args.
|
||||
(let* ((module-or-file-name+options
|
||||
(cond ((and (not (null? options))
|
||||
(or (string? (car options))
|
||||
(list? (car options))))
|
||||
options)
|
||||
(else
|
||||
(cons (module-name (current-module)) options))))
|
||||
(module-or-file-name (car module-or-file-name+options))
|
||||
(trap-options (cdr module-or-file-name+options))
|
||||
;; Create the new breakpoint object.
|
||||
(bp (make <break-in>
|
||||
#:procedure-name procedure-name
|
||||
#:module-or-file-name module-or-file-name
|
||||
#:trap-options (if (memq #:behaviour trap-options)
|
||||
trap-options
|
||||
(cons* #:behaviour
|
||||
(default-breakpoint-behaviour)
|
||||
trap-options)))))
|
||||
;; Add it to the global breakpoint list.
|
||||
(add-to-global-breakpoint-list bp)
|
||||
;; Set the new breakpoint, if possible, in already loaded code.
|
||||
(set-in-existing-code bp)
|
||||
;; Return the breakpoint object to our caller.
|
||||
bp))
|
||||
|
||||
;; break-at: create a `break-at' breakpoint.
|
||||
(define (break-at file-name line column . trap-options)
|
||||
;; Create the new breakpoint object.
|
||||
(let* ((bp (make <break-at>
|
||||
#:file-name file-name
|
||||
#:line line
|
||||
#:column column
|
||||
#:trap-options (if (memq #:behaviour trap-options)
|
||||
trap-options
|
||||
(cons* #:behaviour
|
||||
(default-breakpoint-behaviour)
|
||||
trap-options)))))
|
||||
;; Add it to the global breakpoint list.
|
||||
(add-to-global-breakpoint-list bp)
|
||||
;; Set the new breakpoint, if possible, in already loaded code.
|
||||
(set-in-existing-code bp)
|
||||
;; Return the breakpoint object to our caller.
|
||||
bp))
|
||||
|
||||
;; Set a `break-in' breakpoint in already loaded code, if possible.
|
||||
(define-method (set-in-existing-code (bp <break-in>))
|
||||
;; Get the module or file name that was specified for this
|
||||
;; breakpoint.
|
||||
(let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
|
||||
;; Handling is simpler for a module name.
|
||||
(cond ((list? module-or-file-name)
|
||||
;; See if the named module exists yet.
|
||||
(let ((m (module-if-already-loaded module-or-file-name)))
|
||||
(maybe-break-in-module-proc m bp)))
|
||||
((string? module-or-file-name)
|
||||
;; Try all loaded modules.
|
||||
(or-map (lambda (m)
|
||||
(maybe-break-in-module-proc m bp))
|
||||
(all-loaded-modules)))
|
||||
(else
|
||||
(error "Bad module-or-file-name:" module-or-file-name)))))
|
||||
|
||||
(define (make-observer bp trap)
|
||||
(lambda (event)
|
||||
(trap-target-gone bp trap)))
|
||||
|
||||
;; Set a `break-at' breakpoint in already loaded code, if possible.
|
||||
(define-method (set-in-existing-code (bp <break-at>) . code)
|
||||
;; Procedure to install a source trap on each expression that we
|
||||
;; find matching this breakpoint.
|
||||
(define (install-source-trap x)
|
||||
(or (or-map (lambda (trap)
|
||||
(and (is-a? trap <source-trap>)
|
||||
(eq? (slot-ref trap 'expression) x)))
|
||||
(slot-ref bp 'traps))
|
||||
(let ((trap (apply make <source-trap>
|
||||
#:expression x
|
||||
(slot-ref bp 'trap-options))))
|
||||
(slot-set! trap 'observer (make-observer bp trap))
|
||||
(install-trap trap)
|
||||
(trc 'install-source-trap (object-address trap) (object-address x))
|
||||
(trap-installed bp trap #t))))
|
||||
;; Scan the source whash, and install a trap on all code matching
|
||||
;; this breakpoint.
|
||||
(trc 'set-in-existing-code (length code))
|
||||
(if (null? code)
|
||||
(scan-source-whash (slot-ref bp 'file-name)
|
||||
(slot-ref bp 'line)
|
||||
(slot-ref bp 'column)
|
||||
install-source-trap)
|
||||
(scan-code (car code)
|
||||
(slot-ref bp 'file-name)
|
||||
(slot-ref bp 'line)
|
||||
(slot-ref bp 'column)
|
||||
install-source-trap)))
|
||||
|
||||
;; Temporary implementation of scan-source-whash - this _really_ needs
|
||||
;; to be implemented in C.
|
||||
(define (scan-source-whash file-name line column proc)
|
||||
;; Procedure to call for each source expression in the whash.
|
||||
(define (folder x props acc)
|
||||
(if (and (= line (source-property x 'line))
|
||||
(= column (source-property x 'column))
|
||||
(let ((fn (source-property x 'filename)))
|
||||
(trc 'scan-source-whash fn)
|
||||
(and (string? fn)
|
||||
(string-contains fn file-name))))
|
||||
(proc x)))
|
||||
;; Tracing.
|
||||
(trc 'scan-source-whash file-name line column)
|
||||
;; Apply this procedure to the whash.
|
||||
(hash-fold folder 0 source-whash))
|
||||
|
||||
(define (scan-code x file-name line column proc)
|
||||
(trc 'scan-code file-name line column)
|
||||
(if (pair? x)
|
||||
(begin
|
||||
(if (and (eq? line (source-property x 'line))
|
||||
(eq? column (source-property x 'column))
|
||||
(let ((fn (source-property x 'filename)))
|
||||
(trc 'scan-code fn)
|
||||
(and (string? fn)
|
||||
(string-contains fn file-name))))
|
||||
(proc x))
|
||||
(scan-code (car x) file-name line column proc)
|
||||
(scan-code (cdr x) file-name line column proc))))
|
||||
|
||||
;; If a module named MODULE-NAME has been loaded, return its module
|
||||
;; object; otherwise return #f.
|
||||
(define (module-if-already-loaded module-name)
|
||||
(nested-ref the-root-module (append '(app modules) module-name)))
|
||||
|
||||
;; Construct and return a list of all loaded modules.
|
||||
(define (all-loaded-modules)
|
||||
;; This is the list that accumulates known modules. It has to be
|
||||
;; defined outside the following functions, and accumulated using
|
||||
;; set!, so as to avoid infinite loops - because of the fact that
|
||||
;; all non-pure modules have a variable `app'.
|
||||
(define known-modules '())
|
||||
;; Return an alist of submodules of the given PARENT-MODULE-NAME.
|
||||
;; Each element of the alist is (NAME . MODULE), where NAME is the
|
||||
;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and
|
||||
;; MODULE is the module object. By a "submodule of a parent
|
||||
;; module", we mean any module value that is bound to a symbol in
|
||||
;; the parent module, and which is not an interface module.
|
||||
(define (direct-submodules parent-module-name)
|
||||
(filter (lambda (name+value)
|
||||
(and (module? (cdr name+value))
|
||||
(not (eq? (module-kind (cdr name+value)) 'interface))))
|
||||
(map (lambda (name)
|
||||
(cons name (local-ref (append parent-module-name
|
||||
(list name)))))
|
||||
(cdar (lls parent-module-name)))))
|
||||
;; Add all submodules (direct and indirect) of the module named
|
||||
;; PARENT-MODULE-NAME to `known-modules', if not already there.
|
||||
(define (add-submodules-of parent-module-name)
|
||||
(let ((ds (direct-submodules parent-module-name)))
|
||||
(for-each
|
||||
(lambda (name+module)
|
||||
(or (memq (cdr name+module) known-modules)
|
||||
(begin
|
||||
(set! known-modules (cons (cdr name+module) known-modules))
|
||||
(add-submodules-of (append parent-module-name
|
||||
(list (car name+module)))))))
|
||||
ds)))
|
||||
;; Add submodules recursively, starting from the root of all
|
||||
;; modules.
|
||||
(add-submodules-of '(app modules))
|
||||
;; Return the result.
|
||||
known-modules)
|
||||
|
||||
;; Before-load setup for `break-at' breakpoints.
|
||||
(define-method (setup-before-load (bp <break-at>) filename)
|
||||
(let ((trap (apply make <location-trap>
|
||||
#:file-regexp (regexp-quote (slot-ref bp 'file-name))
|
||||
#:line (slot-ref bp 'line)
|
||||
#:column (slot-ref bp 'column)
|
||||
(slot-ref bp 'trap-options))))
|
||||
(install-trap trap)
|
||||
(trap-installed bp trap #f)
|
||||
(letrec ((uninstaller
|
||||
(lambda (file-name)
|
||||
(uninstall-trap trap)
|
||||
(remove-hook! after-load-hook uninstaller))))
|
||||
(add-hook! after-load-hook uninstaller))))
|
||||
|
||||
;; After-load setup for `break-in' breakpoints.
|
||||
(define-method (setup-after-load (bp <break-in>) filename)
|
||||
;; Get the module that the loaded file created or was loaded into,
|
||||
;; and the module or file name that were specified for this
|
||||
;; breakpoint.
|
||||
(let ((m (current-module))
|
||||
(module-or-file-name (slot-ref bp 'module-or-file-name)))
|
||||
;; Decide whether the breakpoint spec matches this load.
|
||||
(if (or (and (string? module-or-file-name)
|
||||
(string-contains filename module-or-file-name))
|
||||
(and (list? module-or-file-name)
|
||||
(equal? (module-name (current-module)) module-or-file-name)))
|
||||
;; It does, so try to install the breakpoint.
|
||||
(maybe-break-in-module-proc m bp))))
|
||||
|
||||
;; After-load setup for `break-at' breakpoints.
|
||||
(define-method (setup-after-load (bp <break-at>) filename)
|
||||
(if (string-contains filename (slot-ref bp 'file-name))
|
||||
(set-in-existing-code bp)))
|
||||
|
||||
(define (maybe-break-in-module-proc m bp)
|
||||
"If module M defines a procedure matching the specification of
|
||||
breakpoint BP, install a trap on it."
|
||||
(let ((proc (module-ref m (slot-ref bp 'procedure-name) #f)))
|
||||
(if (and proc
|
||||
(procedure? proc)
|
||||
(let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
|
||||
(if (string? module-or-file-name)
|
||||
(source-file-matches (procedure-source proc)
|
||||
module-or-file-name)
|
||||
#t))
|
||||
(not (or-map (lambda (trap)
|
||||
(and (is-a? trap <procedure-trap>)
|
||||
(eq? (slot-ref trap 'procedure) proc)))
|
||||
(slot-ref bp 'traps))))
|
||||
;; There is, so install a <procedure-trap> on it.
|
||||
(letrec ((trap (apply make <procedure-trap>
|
||||
#:procedure proc
|
||||
(slot-ref bp 'trap-options))))
|
||||
(slot-set! trap 'observer (make-observer bp trap))
|
||||
(install-trap trap)
|
||||
(trap-installed bp trap #t)
|
||||
;; Tell caller that we installed a trap.
|
||||
#t)
|
||||
;; Tell caller that we did not install a trap.
|
||||
#f)))
|
||||
|
||||
;; After-read setup for `break-at' breakpoints.
|
||||
(define-method (setup-after-read (bp <break-at>) x)
|
||||
(set-in-existing-code bp x))
|
||||
|
||||
;; Common code for associating a newly created and installed trap with
|
||||
;; a breakpoint object.
|
||||
(define (trap-installed bp trap record?)
|
||||
(if record?
|
||||
;; Remember this trap in the breakpoint object.
|
||||
(slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap))))
|
||||
;; Update the breakpoint status.
|
||||
(call-observer bp))
|
||||
|
||||
;; Common code for handling when the target of one of a breakpoint's
|
||||
;; traps is being GC'd.
|
||||
(define (trap-target-gone bp trap)
|
||||
(trc 'trap-target-gone (object-address trap))
|
||||
;; Remove this trap from the breakpoint's list.
|
||||
(slot-set! bp 'traps (delq! trap (slot-ref bp 'traps)))
|
||||
;; Update the breakpoint status.
|
||||
(call-observer bp))
|
||||
|
||||
(define (source-file-matches source file-name)
|
||||
"Return #t if any of the expressions in SOURCE have a 'filename
|
||||
source property that includes FILE-NAME; otherwise return #f."
|
||||
(and (pair? source)
|
||||
(or (let ((source-file-name (source-property source 'filename)))
|
||||
(and source-file-name
|
||||
(string? source-file-name)
|
||||
(string-contains source-file-name file-name)))
|
||||
(let loop ((source source))
|
||||
(and (pair? source)
|
||||
(or (source-file-matches (car source) file-name)
|
||||
(loop (cdr source))))))))
|
||||
|
||||
;; Install load hook functions.
|
||||
(add-hook! before-load-hook
|
||||
(lambda (fn)
|
||||
(for-each-breakpoint setup-before-load fn)))
|
||||
|
||||
(add-hook! after-load-hook
|
||||
(lambda (fn)
|
||||
(for-each-breakpoint setup-after-load fn)))
|
||||
|
||||
;;; Apply generic function GF to each breakpoint, passing the
|
||||
;;; breakpoint object and ARGS as args on each call.
|
||||
(define (for-each-breakpoint gf . args)
|
||||
(for-each (lambda (bp)
|
||||
(apply gf bp args))
|
||||
breakpoints))
|
||||
|
||||
;; Make sure that recording of source positions is enabled. Without
|
||||
;; this break-at breakpoints will obviously not work.
|
||||
(read-enable 'positions)
|
||||
|
||||
;;; (ice-9 debugging breakpoints) ends here.
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
|
||||
(define-module (ice-9 debugging load-hooks)
|
||||
#:export (before-load-hook
|
||||
after-load-hook
|
||||
install-load-hooks
|
||||
uninstall-load-hooks))
|
||||
|
||||
;; real-primitive-load: holds the real (C-implemented) definition of
|
||||
;; primitive-load, when the load hooks are installed.
|
||||
(define real-primitive-load #f)
|
||||
|
||||
;; The load hooks themselves. These are called with one argument, the
|
||||
;; name of the file concerned.
|
||||
(define before-load-hook (make-hook 1))
|
||||
(define after-load-hook (make-hook 1))
|
||||
|
||||
;; primitive-load-with-hooks: our new definition for primitive-load.
|
||||
(define (primitive-load-with-hooks filename)
|
||||
(run-hook before-load-hook filename)
|
||||
(real-primitive-load filename)
|
||||
(run-hook after-load-hook filename))
|
||||
|
||||
(define (install-load-hooks)
|
||||
(if real-primitive-load
|
||||
(error "load hooks are already installed"))
|
||||
(set! real-primitive-load primitive-load)
|
||||
(set! primitive-load primitive-load-with-hooks))
|
||||
|
||||
(define (uninstall-load-hooks)
|
||||
(or real-primitive-load
|
||||
(error "load hooks are not installed"))
|
||||
(set! primitive-load real-primitive-load)
|
||||
(set! real-primitive-load #f))
|
||||
|
|
@ -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?))
|
||||
|
|
|
|||
117
lib/Makefile.am
117
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 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 extensions full-read full-write strcase strftime
|
||||
|
||||
AUTOMAKE_OPTIONS = 1.5 gnits
|
||||
|
||||
SUBDIRS =
|
||||
noinst_HEADERS =
|
||||
noinst_LIBRARIES =
|
||||
noinst_LTLIBRARIES =
|
||||
|
|
@ -63,6 +64,18 @@ EXTRA_DIST += alloca.in.h
|
|||
|
||||
## end gnulib module alloca-opt
|
||||
|
||||
## 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
|
||||
|
|
@ -71,6 +84,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)
|
||||
|
|
@ -167,6 +198,80 @@ 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
|
||||
|
||||
## end gnulib module verify
|
||||
|
||||
## begin gnulib module wchar
|
||||
|
||||
BUILT_SOURCES += $(WCHAR_H)
|
||||
|
|
@ -181,6 +286,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)' \
|
||||
|
|
@ -193,11 +299,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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
*
|
||||
|
|
@ -236,13 +238,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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
@ -833,9 +835,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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -1138,32 +1138,56 @@ 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.
|
||||
|
||||
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. */
|
||||
psb.pt = pt;
|
||||
psb.buffer = buffer;
|
||||
psb.size = size;
|
||||
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
|
||||
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. */
|
||||
while (pt->read_buf_size && (scm_fill_input (port) != EOF))
|
||||
buffer.) */
|
||||
if (pt->read_buf_size <= 1)
|
||||
{
|
||||
pt->read_buf_size -= (pt->read_end - pt->read_pos);
|
||||
pt->read_pos = pt->read_buf = pt->read_end;
|
||||
}
|
||||
n_read += pt->read_buf - (unsigned char *) buffer;
|
||||
/* 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.
|
||||
|
||||
/* Reinstate the port's normal buffer. */
|
||||
scm_dynwind_end ();
|
||||
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;
|
||||
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
|
||||
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. */
|
||||
while (pt->read_buf_size && (scm_fill_input (port) != EOF))
|
||||
{
|
||||
pt->read_buf_size -= (pt->read_end - pt->read_pos);
|
||||
pt->read_pos = pt->read_buf = pt->read_end;
|
||||
}
|
||||
n_read += pt->read_buf - (unsigned char *) buffer;
|
||||
|
||||
/* 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -636,10 +636,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
|
||||
|
|
@ -659,10 +666,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);
|
||||
|
|
|
|||
|
|
@ -409,8 +409,14 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char)))
|
||||
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 (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
|
||||
{
|
||||
data = scm_alloc_struct (basic_size + tail_elts,
|
||||
|
|
@ -442,15 +448,6 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
|
|||
&prev_finalizer_data);
|
||||
}
|
||||
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -62,6 +62,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)
|
||||
{
|
||||
|
|
@ -460,8 +463,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->admin_mutex, NULL);
|
||||
t->current_mark_stack_ptr = NULL;
|
||||
t->current_mark_stack_limit = NULL;
|
||||
|
|
@ -677,9 +685,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;
|
||||
}
|
||||
|
|
@ -1793,7 +1810,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 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 extensions full-read full-write strcase strftime
|
||||
|
||||
# Specification in the form of a few gnulib-tool.m4 macro invocations:
|
||||
gl_LOCAL_DIR([])
|
||||
|
|
@ -23,6 +23,8 @@ gl_MODULES([
|
|||
alloca
|
||||
autobuild
|
||||
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])
|
||||
|
|
|
|||
|
|
@ -47,13 +47,19 @@ LTALLOCA=`echo "$ALLOCA" | sed 's/\.[^.]* /.lo /g;s/\.[^.]*$/.lo/'`
|
|||
changequote([, ])dnl
|
||||
AC_SUBST([LTALLOCA])
|
||||
gl_FUNC_ALLOCA
|
||||
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
|
||||
|
|
@ -185,7 +191,14 @@ AC_DEFUN([gl_FILE_LIST], [
|
|||
build-aux/link-warning.h
|
||||
lib/alloca.c
|
||||
lib/alloca.in.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
|
||||
|
|
@ -194,13 +207,19 @@ 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/extensions.m4
|
||||
m4/gnulib-common.m4
|
||||
m4/include_next.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
|
||||
|
|
@ -208,5 +227,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],
|
||||
[gl_cv_have_include_next=no])
|
||||
CPPFLAGS="$save_CPPFLAGS"
|
||||
rm -rf conftestd1 conftestd2
|
||||
[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="$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
|
||||
INCLUDE_NEXT=include
|
||||
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
|
||||
])
|
||||
])
|
||||
|
|
@ -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.
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
17
test-suite/standalone/.gitignore
vendored
17
test-suite/standalone/.gitignore
vendored
|
|
@ -1,7 +1,10 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -107,6 +107,13 @@ TESTS += test-conversion
|
|||
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 +122,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
|
||||
|
||||
|
|
|
|||
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;
|
||||
}
|
||||
|
|
@ -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!
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
|
||||
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
|
||||
;;;;
|
||||
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1999, 2001, 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
|
||||
|
|
@ -160,15 +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)))
|
||||
(string-set! (substring/read-only "abc" 0) 1 #\space))
|
||||
|
||||
(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