mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: GUILE-VERSION test-suite/tests/srfi-4.test
This commit is contained in:
Andy Wingo
commit
ab4bc85398
73 changed files with 1292 additions and 335 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -142,3 +142,4 @@ INSTALL
|
|||
/test-suite/standalone/test-scm-spawn-thread
|
||||
/test-suite/standalone/test-pthread-create
|
||||
/test-suite/standalone/test-pthread-create-secondary
|
||||
/lib/fcntl.h
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ GUILE_EFFECTIVE_VERSION=2.2
|
|||
# See libtool info pages for more information on how and when to
|
||||
# change these.
|
||||
|
||||
LIBGUILE_INTERFACE_CURRENT=23
|
||||
LIBGUILE_INTERFACE_CURRENT=24
|
||||
LIBGUILE_INTERFACE_REVISION=0
|
||||
LIBGUILE_INTERFACE_AGE=1
|
||||
LIBGUILE_INTERFACE_AGE=2
|
||||
LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
|
||||
|
|
|
|||
7
NEWS
7
NEWS
|
|
@ -162,11 +162,16 @@ ports)' documentation from the R6RS documentation. Thanks Andreas!
|
|||
** Fix call-with-input-file & relatives for multiple values
|
||||
** Fix `hash' for inf and nan
|
||||
** Fix libguile internal type errors caught by typing-strictness==2
|
||||
** Fix compile error in mingw fstat socket detection
|
||||
** Fix compile error in MinGW fstat socket detection
|
||||
** Fix generation of auto-compiled file names on MinGW
|
||||
** Fix multithreaded access to internal hash tables
|
||||
** Emit a 1-based line number in error messages
|
||||
** Fix define-module ordering
|
||||
** Fix several POSIX functions to use the locale encoding
|
||||
** Add type and range checks to the complex generalized vector accessors
|
||||
** Fix unaligned accesses for bytevectors of complex numbers
|
||||
** Fix '(a #{.} b)
|
||||
** Fix erroneous VM stack overflow for canceled threads
|
||||
|
||||
|
||||
Changes in 2.0.1 (since 2.0.0):
|
||||
|
|
|
|||
|
|
@ -374,13 +374,14 @@ AC_DEFUN([GUILE_THREAD_LOCAL_STORAGE], [
|
|||
dnl
|
||||
dnl Known broken systems includes:
|
||||
dnl - x86_64-unknown-netbsd5.0.
|
||||
dnl - x86_64-unknown-netbsd5.1
|
||||
dnl - sparc-sun-solaris2.8
|
||||
dnl
|
||||
dnl On `x86_64-unknown-freebsd8.0', thread-local storage appears to
|
||||
dnl be reclaimed at the wrong time, leading to a segfault when
|
||||
dnl running `threads.test'. So disable it.
|
||||
case "$enable_shared--$host_os" in
|
||||
[yes--netbsd[0-5].[0-9].|yes--solaris2.8|yes--freebsd[0-8]*])
|
||||
[yes--netbsd[0-5].[0-9]*|yes--solaris2.8|yes--freebsd[0-8]*])
|
||||
ac_cv_have_thread_storage_class="no"
|
||||
;;
|
||||
*)
|
||||
|
|
|
|||
|
|
@ -35,7 +35,8 @@ AC_CONFIG_AUX_DIR([build-aux])
|
|||
AC_CONFIG_MACRO_DIR([m4])
|
||||
AC_CONFIG_SRCDIR(GUILE-VERSION)
|
||||
|
||||
AM_INIT_AUTOMAKE([gnu no-define -Wall -Wno-override])
|
||||
dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11.
|
||||
AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override dist-xz])
|
||||
m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)])
|
||||
|
||||
AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
|
||||
|
|
@ -1635,6 +1636,10 @@ pkgdatadir="$datadir/$PACKAGE_TARNAME"
|
|||
sitedir="$pkgdatadir/site/$GUILE_EFFECTIVE_VERSION"
|
||||
AC_SUBST([sitedir])
|
||||
|
||||
dnl Name of the `guile' program.
|
||||
guile_program_name="`echo guile | "$SED" "$program_transform_name"`"
|
||||
AC_SUBST([guile_program_name])
|
||||
|
||||
# Additional SCM_I_GSC definitions are above.
|
||||
AC_SUBST([SCM_I_GSC_GUILE_DEBUG])
|
||||
AC_SUBST([SCM_I_GSC_ENABLE_DEPRECATED])
|
||||
|
|
|
|||
|
|
@ -90,6 +90,7 @@ guile_TEXINFOS = preface.texi \
|
|||
mod-getopt-long.texi \
|
||||
goops.texi \
|
||||
goops-tutorial.texi \
|
||||
guile-invoke.texi \
|
||||
effective-version.texi
|
||||
|
||||
ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 2008, 2009
|
||||
@c Copyright (C) 2008, 2009, 2011
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
|
|
@ -822,9 +822,10 @@ Here is an example:
|
|||
#:export (x y z ...))
|
||||
|
||||
(define-module (my-module)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (math 2D-vectors)
|
||||
#:use-module (math 3D-vectors)
|
||||
#:duplicates merge-generics)
|
||||
#:duplicates (merge-generics))
|
||||
@end lisp
|
||||
|
||||
The generic function @code{x} in @code{(my-module)} will now incorporate
|
||||
|
|
|
|||
|
|
@ -704,17 +704,15 @@ information.
|
|||
Guile also comes with a growing number of command-line utilities: a
|
||||
compiler, a disassembler, some module inspectors, and in the future, a
|
||||
system to install Guile packages from the internet. These tools may be
|
||||
invoked using the @code{guild} program@footnote{Until Guile version
|
||||
2.0.1, this program was known as @code{guile-tools}. The
|
||||
@code{guile-tools} executable is still installed as of 2.0.x but may be
|
||||
removed in a future stable series.}.
|
||||
invoked using the @code{guild} program.
|
||||
|
||||
@example
|
||||
$ guild compile -o foo.go foo.scm
|
||||
wrote `foo.go'
|
||||
@end example
|
||||
|
||||
This program used to be called @code{guile-tools}, and for backward
|
||||
This program used to be called @code{guile-tools} up to
|
||||
Guile version 2.0.1, and for backward
|
||||
compatibility it still may be called as such. However we changed the
|
||||
name to @code{guild}, not only because it is pleasantly shorter and
|
||||
easier to read, but also because this tool will serve to bind Guile
|
||||
|
|
|
|||
164
doc/release.org
Normal file
164
doc/release.org
Normal file
|
|
@ -0,0 +1,164 @@
|
|||
#+TITLE: Release Process for GNU Guile 2.0
|
||||
#+AUTHOR: Ludovic Courtès
|
||||
#+EMAIL: ludo@gnu.org
|
||||
|
||||
This document describes the typical release process for Guile 2.0.
|
||||
|
||||
* Preparing & uploading the tarball
|
||||
|
||||
** Update Gnulib
|
||||
|
||||
The commit log's first line should be "Update Gnulib to X", where X is
|
||||
the output of `git describe' in the Gnulib repo.
|
||||
|
||||
This allows us to keep track of the source code we use, in case a bug or
|
||||
security vulnerability gets fixed in Gnulib sometime later.
|
||||
|
||||
Ideally update Gnulib several days prior to the release, so that
|
||||
portability or build issues can be uncovered in time.
|
||||
|
||||
** Make sure it works, portably, and with different configurations
|
||||
|
||||
*** Check [[http://hydra.nixos.org/jobset/gnu/guile-2-0][Hydra]]
|
||||
|
||||
This contains builds and cross-builds on different platforms, with
|
||||
different `configure' switches, different CPPFLAGS, and different
|
||||
versions of the compiler.
|
||||
|
||||
As of this writing, there are unfixed failures. For instance Darwin's
|
||||
compiler randomly crashes, preventing build completion; the FreeBSD 7.x
|
||||
box experiences Guile crashes while running the test suite, which were
|
||||
not fixed because not reproduced elsewhere. Even for these platforms,
|
||||
make sure "things don't get worse", at least.
|
||||
|
||||
*** Check [[http://autobuild.josefsson.org/guile/][Autobuild]]
|
||||
|
||||
This contains build reports from other people, typically on lesser used
|
||||
platforms, so it's worth checking.
|
||||
|
||||
*** Use the [[http://gcc.gnu.org/wiki/CompileFarm][GCC Compile Farm]]
|
||||
|
||||
Use the GCC Compile Farm to check on lesser used architectures or
|
||||
operating systems. In particular, the Farm has ARM, SPARC64, PowerPC,
|
||||
and MIPS GNU/Linux boxes (remember that this is not superfluous: Debian
|
||||
builds on 11 architectures). It also has FreeBSD and NetBSD boxes.
|
||||
|
||||
*** Use porter boxes
|
||||
|
||||
If you're still in a good mood, you may also want to check on porter
|
||||
boxes for other OSes. The GNU/Hurd people have [[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], so does
|
||||
the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]].
|
||||
|
||||
** Update `GUILE-VERSION'
|
||||
|
||||
For stable releases, make sure to update the SONAME appropriately. To
|
||||
that end, review the commit logs for libguile in search of any C ABI
|
||||
changes (new functions added, existing functions deprecated, etc.)
|
||||
Change `LIBGUILE_INTERFACE_*' accordingly. Re-read the Libtool manual
|
||||
if in doubt.
|
||||
|
||||
`libguile/libguile.map' should also be updated as new public symbols are
|
||||
added. Ideally, new symbols should get under a new version
|
||||
symbol---e.g., `GUILE_2.0.3' for symbols introduced in Guile 2.0.3.
|
||||
However, this has not been done for Guile <= 2.0.2.
|
||||
|
||||
** Tag v2.0.x
|
||||
|
||||
Create a signed Git tag, like this:
|
||||
|
||||
$ git tag -s u MY-KEY -m "GNU Guile 2.0.X." v2.0.X
|
||||
|
||||
The tag *must* be `v2.0.X'. For the sake of consistency, always use
|
||||
"GNU Guile 2.0.X." as the tag comment.
|
||||
|
||||
** Push the tag and changes
|
||||
|
||||
$ git push && git push --tags
|
||||
|
||||
Normally nobody committed in the meantime. ;-)
|
||||
|
||||
** Run "make dist"
|
||||
|
||||
This should trigger an `autoreconf', as `build-aux/git-version-gen'
|
||||
notices the new tag. After "make dist", double-check that `./configure
|
||||
--version' reports the new version number.
|
||||
|
||||
The reason for running "make dist" instead of "make distcheck" is that
|
||||
it's much faster and any distribution issues should have been caught by
|
||||
Hydra already.
|
||||
|
||||
** Upload
|
||||
|
||||
$ ./build-aux/gnupload --to ftp.gnu.org:guile guile-2.0.X.tar.gz
|
||||
|
||||
You'll get an email soon after when the upload is complete.
|
||||
|
||||
Your GPG public key must be registered for this to work (info
|
||||
"(maintain) Automated Upload Registration").
|
||||
|
||||
Make sure to publish your public key on public OpenPGP servers
|
||||
(keys.gnupg.net, pgp.mit.edu, etc.), so that people can actually use it
|
||||
to check the authenticity and integrity of the tarball.
|
||||
|
||||
** Download
|
||||
|
||||
Make sure the file was uploaded and is available for download as
|
||||
expected:
|
||||
|
||||
$ mkdir t && cd t && wget ftp.gnu.org/gnu/guile/guile-2.0.X.tar.gz
|
||||
$ diff guile-2.0.X.tar.gz ../guile-2.0.X.tar.gz
|
||||
|
||||
You're almost done!
|
||||
|
||||
* Announcements
|
||||
|
||||
First, re-read the GNU Maintainers Guide on this topic (info "(maintain)
|
||||
Announcements").
|
||||
|
||||
** Update web pages
|
||||
|
||||
- Replace any references to the previous version number and replace it
|
||||
with the new one.
|
||||
- Update news.html.
|
||||
|
||||
** Update the on-line copy of the manual
|
||||
|
||||
- Use `build-aux/gendocs', add to the manual/ directory of the web
|
||||
site.
|
||||
|
||||
** Prepare the email announcement
|
||||
|
||||
$ build-aux/announce-gen --release-type=stable --package-name=guile \
|
||||
--previous-version=2.0.1 --current-version=2.0.2 \
|
||||
--gpg-key-id=MY-KEY --url-directory=ftp://ftp.gnu.org/gnu/guile \
|
||||
--bootstrap-tools=autoconf,automake,libtool,gnulib \
|
||||
--gnulib-version=$( cd ~/src/gnulib ; git describe )
|
||||
|
||||
The subject must be "GNU Guile 2.0.X released". The text should remain
|
||||
formal and impersonal (it is sent on behalf of the Guile and GNU
|
||||
projects.) It must include a description of what Guile is (not everyone
|
||||
reading info-gnu may know about it.) Use the text of previous
|
||||
announcements as a template.
|
||||
|
||||
Below the initial boilerplate that describes Guile should come the
|
||||
output of `announce-gen', and then the `NEWS' file excerpt in its
|
||||
entirety (don't call it a change log since that's not what it is.)
|
||||
|
||||
** Send the email announcement
|
||||
|
||||
- guile-user@gnu.org, guile-devel@gnu.org, guile-sources@gnu.org
|
||||
- info-gnu@gnu.org (for stable releases only!)
|
||||
- comp.lang.scheme
|
||||
|
||||
** Post a news on [[http://sv.gnu.org/p/guile/][Savannah]]
|
||||
|
||||
The news will end up on planet.gnu.org. The text can be shorter and
|
||||
more informal, with a link to the email announcement for details.
|
||||
|
||||
|
||||
|
||||
Copyright © 2011 Free Software Foundation, Inc.
|
||||
|
||||
Copying and distribution of this file, with or without modification,
|
||||
are permitted in any medium without royalty provided the copyright
|
||||
notice and this notice are preserved.
|
||||
|
|
@ -420,7 +420,9 @@ float.h: $(top_builddir)/config.status
|
|||
endif
|
||||
MOSTLYCLEANFILES += float.h float.h-t
|
||||
|
||||
EXTRA_DIST += float.in.h
|
||||
EXTRA_DIST += float.c float.in.h
|
||||
|
||||
EXTRA_libgnu_la_SOURCES += float.c
|
||||
|
||||
## end gnulib module float
|
||||
|
||||
|
|
|
|||
33
lib/float.c
Normal file
33
lib/float.c
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
/* Auxiliary definitions for <float.h>.
|
||||
Copyright (C) 2011 Free Software Foundation, Inc.
|
||||
Written by Bruno Haible <bruno@clisp.org>, 2011.
|
||||
|
||||
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 <float.h>
|
||||
|
||||
#if (defined _ARCH_PPC || defined _POWER) && defined _AIX && (LDBL_MANT_DIG == 106) && defined __GNUC__
|
||||
const union gl_long_double_union gl_LDBL_MAX =
|
||||
{ { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL } };
|
||||
#elif defined __i386__
|
||||
const union gl_long_double_union gl_LDBL_MAX =
|
||||
{ { 0xFFFFFFFF, 0xFFFFFFFF, 32766 } };
|
||||
#else
|
||||
/* This declaration is solely to ensure that after preprocessing
|
||||
this file is never empty. */
|
||||
typedef int dummy;
|
||||
#endif
|
||||
111
lib/float.in.h
111
lib/float.in.h
|
|
@ -29,6 +29,7 @@
|
|||
#define _@GUARD_PREFIX@_FLOAT_H
|
||||
|
||||
/* 'long double' properties. */
|
||||
|
||||
#if defined __i386__ && (defined __BEOS__ || defined __OpenBSD__)
|
||||
/* Number of mantissa units, in base FLT_RADIX. */
|
||||
# undef LDBL_MANT_DIG
|
||||
|
|
@ -59,5 +60,115 @@
|
|||
# define LDBL_MAX_10_EXP 4932
|
||||
#endif
|
||||
|
||||
/* On FreeBSD/x86 6.4, the 'long double' type really has only 53 bits of
|
||||
precision in the compiler but 64 bits of precision at runtime. See
|
||||
<http://lists.gnu.org/archive/html/bug-gnulib/2008-07/msg00063.html>. */
|
||||
#if defined __i386__ && defined __FreeBSD__
|
||||
/* Number of mantissa units, in base FLT_RADIX. */
|
||||
# undef LDBL_MANT_DIG
|
||||
# define LDBL_MANT_DIG 64
|
||||
/* Number of decimal digits that is sufficient for representing a number. */
|
||||
# undef LDBL_DIG
|
||||
# define LDBL_DIG 18
|
||||
/* x-1 where x is the smallest representable number > 1. */
|
||||
# undef LDBL_EPSILON
|
||||
# define LDBL_EPSILON 1.084202172485504434007452800869941711426e-19L /* 2^-63 */
|
||||
/* Minimum e such that FLT_RADIX^(e-1) is a normalized number. */
|
||||
# undef LDBL_MIN_EXP
|
||||
# define LDBL_MIN_EXP (-16381)
|
||||
/* Maximum e such that FLT_RADIX^(e-1) is a representable finite number. */
|
||||
# undef LDBL_MAX_EXP
|
||||
# define LDBL_MAX_EXP 16384
|
||||
/* Minimum positive normalized number. */
|
||||
# undef LDBL_MIN
|
||||
# define LDBL_MIN 3.3621031431120935E-4932L /* = 0x1p-16382L */
|
||||
/* Maximum representable finite number. */
|
||||
# undef LDBL_MAX
|
||||
/* LDBL_MAX is represented as { 0xFFFFFFFF, 0xFFFFFFFF, 32766 }.
|
||||
But the largest literal that GCC allows us to write is
|
||||
0x0.fffffffffffff8p16384L = { 0xFFFFF800, 0xFFFFFFFF, 32766 }.
|
||||
So, define it like this through a reference to an external variable
|
||||
|
||||
const unsigned int LDBL_MAX[3] = { 0xFFFFFFFF, 0xFFFFFFFF, 32766 };
|
||||
extern const long double LDBL_MAX;
|
||||
|
||||
Unfortunately, this is not a constant expression. */
|
||||
union gl_long_double_union
|
||||
{
|
||||
struct { unsigned int lo; unsigned int hi; unsigned int exponent; } xd;
|
||||
long double ld;
|
||||
};
|
||||
extern const union gl_long_double_union gl_LDBL_MAX;
|
||||
# define LDBL_MAX (gl_LDBL_MAX.ld)
|
||||
/* Minimum e such that 10^e is in the range of normalized numbers. */
|
||||
# undef LDBL_MIN_10_EXP
|
||||
# define LDBL_MIN_10_EXP (-4931)
|
||||
/* Maximum e such that 10^e is in the range of representable finite numbers. */
|
||||
# undef LDBL_MAX_10_EXP
|
||||
# define LDBL_MAX_10_EXP 4932
|
||||
#endif
|
||||
|
||||
/* On AIX 7.1 with gcc 4.2, the values of LDBL_MIN_EXP, LDBL_MIN, LDBL_MAX are
|
||||
wrong. */
|
||||
#if (defined _ARCH_PPC || defined _POWER) && defined _AIX && (LDBL_MANT_DIG == 106) && defined __GNUC__
|
||||
# undef LDBL_MIN_EXP
|
||||
# define LDBL_MIN_EXP DBL_MIN_EXP
|
||||
# undef LDBL_MIN_10_EXP
|
||||
# define LDBL_MIN_10_EXP DBL_MIN_10_EXP
|
||||
# undef LDBL_MIN
|
||||
# define LDBL_MIN 2.22507385850720138309023271733240406422e-308L /* DBL_MIN = 2^-1022 */
|
||||
# undef LDBL_MAX
|
||||
/* LDBL_MAX is represented as { 0x7FEFFFFF, 0xFFFFFFFF, 0x7C8FFFFF, 0xFFFFFFFF }.
|
||||
It is not easy to define:
|
||||
#define LDBL_MAX 1.79769313486231580793728971405302307166e308L
|
||||
is too small, whereas
|
||||
#define LDBL_MAX 1.79769313486231580793728971405302307167e308L
|
||||
is too large. Apparently a bug in GCC decimal-to-binary conversion.
|
||||
Also, I can't get values larger than
|
||||
#define LDBL63 ((long double) (1ULL << 63))
|
||||
#define LDBL882 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63)
|
||||
#define LDBL945 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63)
|
||||
#define LDBL1008 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63)
|
||||
#define LDBL_MAX (LDBL1008 * 65535.0L + LDBL945 * (long double) 9223372036821221375ULL + LDBL882 * (long double) 4611686018427387904ULL)
|
||||
which is represented as { 0x7FEFFFFF, 0xFFFFFFFF, 0x7C8FFFFF, 0xF8000000 }.
|
||||
So, define it like this through a reference to an external variable
|
||||
|
||||
const double LDBL_MAX[2] = { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL };
|
||||
extern const long double LDBL_MAX;
|
||||
|
||||
or through a pointer cast
|
||||
|
||||
#define LDBL_MAX \
|
||||
(*(const long double *) (double[]) { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL })
|
||||
|
||||
Unfortunately, this is not a constant expression, and the latter expression
|
||||
does not work well when GCC is optimizing.. */
|
||||
union gl_long_double_union
|
||||
{
|
||||
struct { double hi; double lo; } dd;
|
||||
long double ld;
|
||||
};
|
||||
extern const union gl_long_double_union gl_LDBL_MAX;
|
||||
# define LDBL_MAX (gl_LDBL_MAX.ld)
|
||||
#endif
|
||||
|
||||
/* On IRIX 6.5, with cc, the value of LDBL_MANT_DIG is wrong.
|
||||
On IRIX 6.5, with gcc 4.2, the values of LDBL_MIN_EXP, LDBL_MIN, LDBL_EPSILON
|
||||
are wrong. */
|
||||
#if defined __sgi && (LDBL_MANT_DIG >= 106)
|
||||
# undef LDBL_MANT_DIG
|
||||
# define LDBL_MANT_DIG 106
|
||||
# if defined __GNUC__
|
||||
# undef LDBL_MIN_EXP
|
||||
# define LDBL_MIN_EXP DBL_MIN_EXP
|
||||
# undef LDBL_MIN_10_EXP
|
||||
# define LDBL_MIN_10_EXP DBL_MIN_10_EXP
|
||||
# undef LDBL_MIN
|
||||
# define LDBL_MIN 2.22507385850720138309023271733240406422e-308L /* DBL_MIN = 2^-1022 */
|
||||
# undef LDBL_EPSILON
|
||||
# define LDBL_EPSILON 2.46519032881566189191165176650870696773e-32L /* 2^-105 */
|
||||
# endif
|
||||
#endif
|
||||
|
||||
#endif /* _@GUARD_PREFIX@_FLOAT_H */
|
||||
#endif /* _@GUARD_PREFIX@_FLOAT_H */
|
||||
|
|
|
|||
|
|
@ -21,17 +21,20 @@
|
|||
|
||||
#include <float.h>
|
||||
|
||||
int gl_isinff (float x)
|
||||
int
|
||||
gl_isinff (float x)
|
||||
{
|
||||
return x < -FLT_MAX || x > FLT_MAX;
|
||||
}
|
||||
|
||||
int gl_isinfd (double x)
|
||||
int
|
||||
gl_isinfd (double x)
|
||||
{
|
||||
return x < -DBL_MAX || x > DBL_MAX;
|
||||
}
|
||||
|
||||
int gl_isinfl (long double x)
|
||||
int
|
||||
gl_isinfl (long double x)
|
||||
{
|
||||
return x < -LDBL_MAX || x > LDBL_MAX;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,6 +19,12 @@
|
|||
#ifndef _PATHMAX_H
|
||||
# define _PATHMAX_H
|
||||
|
||||
/* POSIX:2008 defines PATH_MAX to be the maximum number of bytes in a filename,
|
||||
including the terminating NUL byte.
|
||||
<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/limits.h.html>
|
||||
PATH_MAX is not defined on systems which have no limit on filename length,
|
||||
such as GNU/Hurd. */
|
||||
|
||||
# include <unistd.h>
|
||||
|
||||
# include <limits.h>
|
||||
|
|
@ -45,4 +51,13 @@
|
|||
# define PATH_MAX _POSIX_PATH_MAX
|
||||
# endif
|
||||
|
||||
# ifdef __hpux
|
||||
/* On HP-UX, PATH_MAX designates the maximum number of bytes in a filename,
|
||||
*not* including the terminating NUL byte, and is set to 1023.
|
||||
Additionally, when _XOPEN_SOURCE is defined to 500 or more, PATH_MAX is
|
||||
not defined at all any more. */
|
||||
# undef PATH_MAX
|
||||
# define PATH_MAX 1024
|
||||
# endif
|
||||
|
||||
#endif /* _PATHMAX_H */
|
||||
|
|
|
|||
13
lib/pipe2.c
13
lib/pipe2.c
|
|
@ -40,6 +40,13 @@
|
|||
int
|
||||
pipe2 (int fd[2], int flags)
|
||||
{
|
||||
/* Mingw _pipe() corrupts fd on failure; also, if we succeed at
|
||||
creating the pipe but later fail at changing fcntl, we want
|
||||
to leave fd unchanged: http://austingroupbugs.net/view.php?id=467 */
|
||||
int tmp[2];
|
||||
tmp[0] = fd[0];
|
||||
tmp[1] = fd[1];
|
||||
|
||||
#if HAVE_PIPE2
|
||||
# undef pipe2
|
||||
/* Try the system call first, if it exists. (We may be running with a glibc
|
||||
|
|
@ -71,7 +78,11 @@ pipe2 (int fd[2], int flags)
|
|||
/* Native Woe32 API. */
|
||||
|
||||
if (_pipe (fd, 4096, flags & ~O_NONBLOCK) < 0)
|
||||
{
|
||||
fd[0] = tmp[0];
|
||||
fd[1] = tmp[1];
|
||||
return -1;
|
||||
}
|
||||
|
||||
/* O_NONBLOCK handling.
|
||||
On native Windows platforms, O_NONBLOCK is defined by gnulib. Use the
|
||||
|
|
@ -145,6 +156,8 @@ pipe2 (int fd[2], int flags)
|
|||
int saved_errno = errno;
|
||||
close (fd[0]);
|
||||
close (fd[1]);
|
||||
fd[0] = tmp[0];
|
||||
fd[1] = tmp[1];
|
||||
errno = saved_errno;
|
||||
return -1;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ orig_stat (const char *filename, struct stat *buf)
|
|||
#include <stdbool.h>
|
||||
#include <string.h>
|
||||
#include "dosname.h"
|
||||
#include "verify.h"
|
||||
|
||||
/* Store information about NAME into ST. Work around bugs with
|
||||
trailing slashes. Mingw has other bugs (such as st_ino always
|
||||
|
|
@ -63,6 +64,12 @@ rpl_stat (char const *name, struct stat *st)
|
|||
}
|
||||
#endif /* REPLACE_FUNC_STAT_FILE */
|
||||
#if REPLACE_FUNC_STAT_DIR
|
||||
/* The only known systems where REPLACE_FUNC_STAT_DIR is needed also
|
||||
have a constant PATH_MAX. */
|
||||
# ifndef PATH_MAX
|
||||
# error "Please port this replacement to your platform"
|
||||
# endif
|
||||
|
||||
if (result == -1 && errno == ENOENT)
|
||||
{
|
||||
/* Due to mingw's oddities, there are some directories (like
|
||||
|
|
@ -77,6 +84,7 @@ rpl_stat (char const *name, struct stat *st)
|
|||
char fixed_name[PATH_MAX + 1] = {0};
|
||||
size_t len = strlen (name);
|
||||
bool check_dir = false;
|
||||
verify (PATH_MAX <= 4096);
|
||||
if (PATH_MAX <= len)
|
||||
errno = ENAMETOOLONG;
|
||||
else if (len)
|
||||
|
|
|
|||
|
|
@ -1062,6 +1062,7 @@ _GL_WARN_ON_USE (pipe2, "pipe2 is unportable - "
|
|||
specification <http://www.opengroup.org/susv3xsh/pread.html>. */
|
||||
# if @REPLACE_PREAD@
|
||||
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
|
||||
# undef pread
|
||||
# define pread rpl_pread
|
||||
# endif
|
||||
_GL_FUNCDECL_RPL (pread, ssize_t,
|
||||
|
|
@ -1096,6 +1097,7 @@ _GL_WARN_ON_USE (pread, "pread is unportable - "
|
|||
<http://www.opengroup.org/susv3xsh/pwrite.html>. */
|
||||
# if @REPLACE_PWRITE@
|
||||
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
|
||||
# undef pwrite
|
||||
# define pwrite rpl_pwrite
|
||||
# endif
|
||||
_GL_FUNCDECL_RPL (pwrite, ssize_t,
|
||||
|
|
|
|||
|
|
@ -647,6 +647,7 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status
|
|||
@echo '#define SCM_LIB_DIR "$(libdir)"' >> libpath.tmp
|
||||
@echo '#define SCM_EXTENSIONS_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions"' >> libpath.tmp
|
||||
@echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp
|
||||
@echo '#define SCM_SITE_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/site-ccache"' >> libpath.tmp
|
||||
@echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp
|
||||
@echo '#define SCM_BUILD_INFO { \' >> libpath.tmp
|
||||
@echo ' { "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp
|
||||
|
|
|
|||
|
|
@ -2109,26 +2109,56 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
|
|||
|
||||
/* Bytevectors as generalized vectors & arrays. */
|
||||
|
||||
#define COMPLEX_ACCESSOR_PROLOGUE(_type) \
|
||||
size_t c_len, c_index; \
|
||||
char *c_bv; \
|
||||
\
|
||||
SCM_VALIDATE_BYTEVECTOR (1, bv); \
|
||||
c_index = scm_to_size_t (index); \
|
||||
\
|
||||
c_len = SCM_BYTEVECTOR_LENGTH (bv); \
|
||||
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
|
||||
\
|
||||
if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
|
||||
scm_out_of_range (FUNC_NAME, index);
|
||||
|
||||
/* Template for native access to complex numbers of type TYPE. */
|
||||
#define COMPLEX_NATIVE_REF(_type) \
|
||||
SCM result; \
|
||||
\
|
||||
COMPLEX_ACCESSOR_PROLOGUE (_type); \
|
||||
\
|
||||
{ \
|
||||
_type real, imag; \
|
||||
\
|
||||
memcpy (&real, &c_bv[c_index], sizeof (_type)); \
|
||||
memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
|
||||
\
|
||||
result = scm_c_make_rectangular (real, imag); \
|
||||
} \
|
||||
\
|
||||
return result;
|
||||
|
||||
static SCM
|
||||
bytevector_ref_c32 (SCM bv, SCM idx)
|
||||
{ /* FIXME add some checks */
|
||||
const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
|
||||
size_t i = scm_to_size_t (idx);
|
||||
return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]);
|
||||
bytevector_ref_c32 (SCM bv, SCM index)
|
||||
#define FUNC_NAME "bytevector_ref_c32"
|
||||
{
|
||||
COMPLEX_NATIVE_REF (float);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static SCM
|
||||
bytevector_ref_c64 (SCM bv, SCM idx)
|
||||
{ /* FIXME add some checks */
|
||||
const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
|
||||
size_t i = scm_to_size_t (idx);
|
||||
return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
|
||||
bytevector_ref_c64 (SCM bv, SCM index)
|
||||
#define FUNC_NAME "bytevector_ref_c64"
|
||||
{
|
||||
COMPLEX_NATIVE_REF (double);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
|
||||
|
||||
const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
|
||||
static const scm_t_bytevector_ref_fn
|
||||
bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
|
||||
{
|
||||
NULL, /* SCM */
|
||||
NULL, /* CHAR */
|
||||
|
|
@ -2160,24 +2190,36 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
|
|||
return ref_fn (h->array, byte_index);
|
||||
}
|
||||
|
||||
/* FIXME add checks!!! */
|
||||
static SCM
|
||||
bytevector_set_c32 (SCM bv, SCM idx, SCM val)
|
||||
{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
|
||||
size_t i = scm_to_size_t (idx);
|
||||
contents[i/4] = scm_c_real_part (val);
|
||||
contents[i/4 + 1] = scm_c_imag_part (val);
|
||||
/* Template for native modification of complex numbers of type TYPE. */
|
||||
#define COMPLEX_NATIVE_SET(_type) \
|
||||
COMPLEX_ACCESSOR_PROLOGUE (_type); \
|
||||
\
|
||||
{ \
|
||||
_type real, imag; \
|
||||
real = scm_c_real_part (value); \
|
||||
imag = scm_c_imag_part (value); \
|
||||
\
|
||||
memcpy (&c_bv[c_index], &real, sizeof (_type)); \
|
||||
memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
|
||||
} \
|
||||
\
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
static SCM
|
||||
bytevector_set_c64 (SCM bv, SCM idx, SCM val)
|
||||
{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
|
||||
size_t i = scm_to_size_t (idx);
|
||||
contents[i/8] = scm_c_real_part (val);
|
||||
contents[i/8 + 1] = scm_c_imag_part (val);
|
||||
return SCM_UNSPECIFIED;
|
||||
bytevector_set_c32 (SCM bv, SCM index, SCM value)
|
||||
#define FUNC_NAME "bytevector_set_c32"
|
||||
{
|
||||
COMPLEX_NATIVE_SET (float);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static SCM
|
||||
bytevector_set_c64 (SCM bv, SCM index, SCM value)
|
||||
#define FUNC_NAME "bytevector_set_c64"
|
||||
{
|
||||
COMPLEX_NATIVE_SET (double);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
|
||||
|
||||
|
|
|
|||
|
|
@ -261,8 +261,10 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
|
|||
|
||||
fd = scm_to_int (scm_open_fdes (path, flags, mode));
|
||||
iflags = SCM_NUM2INT (2, flags);
|
||||
if (iflags & O_RDWR)
|
||||
|
||||
if ((iflags & O_RDWR) == O_RDWR)
|
||||
{
|
||||
/* Opened read-write. */
|
||||
if (iflags & O_APPEND)
|
||||
port_mode = "a+";
|
||||
else if (iflags & O_CREAT)
|
||||
|
|
@ -270,7 +272,9 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
|
|||
else
|
||||
port_mode = "r+";
|
||||
}
|
||||
else {
|
||||
else
|
||||
{
|
||||
/* Opened read-only or write-only. */
|
||||
if (iflags & O_APPEND)
|
||||
port_mode = "a";
|
||||
else if (iflags & O_WRONLY)
|
||||
|
|
@ -278,6 +282,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
|
|||
else
|
||||
port_mode = "r";
|
||||
}
|
||||
|
||||
newpt = scm_fdes_to_port (fd, port_mode, path);
|
||||
return newpt;
|
||||
}
|
||||
|
|
@ -1857,6 +1862,9 @@ scm_init_filesys ()
|
|||
#ifdef O_LARGEFILE
|
||||
scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
|
||||
#endif
|
||||
#ifdef O_NOTRANS
|
||||
scm_c_define ("O_NOTRANS", scm_from_int (O_NOTRANS));
|
||||
#endif
|
||||
|
||||
#ifdef F_DUPFD
|
||||
scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));
|
||||
|
|
|
|||
|
|
@ -2284,15 +2284,21 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
|
|||
*
|
||||
******************************************************************************/
|
||||
|
||||
/* Munge the CPL of C in place such that BEFORE appears before AFTER,
|
||||
assuming that currently the reverse is true. Recalculate slots and
|
||||
associated getters-n-setters. */
|
||||
static void
|
||||
fix_cpl (SCM c, SCM before, SCM after)
|
||||
{
|
||||
SCM cpl = SCM_SLOT (c, scm_si_cpl);
|
||||
SCM ls = scm_c_memq (after, cpl);
|
||||
SCM tail = scm_delq1_x (before, SCM_CDR (ls));
|
||||
SCM tail;
|
||||
|
||||
if (scm_is_false (ls))
|
||||
/* if this condition occurs, fix_cpl should not be applied this way */
|
||||
abort ();
|
||||
|
||||
tail = scm_delq1_x (before, SCM_CDR (ls));
|
||||
SCM_SETCAR (ls, before);
|
||||
SCM_SETCDR (ls, scm_cons (after, tail));
|
||||
{
|
||||
|
|
@ -2418,8 +2424,8 @@ create_standard_classes (void)
|
|||
make_stdcls (&scm_class_extended_generic_with_setter,
|
||||
"<extended-generic-with-setter>",
|
||||
scm_class_applicable_struct_class,
|
||||
scm_list_2 (scm_class_generic_with_setter,
|
||||
scm_class_extended_generic),
|
||||
scm_list_2 (scm_class_extended_generic,
|
||||
scm_class_generic_with_setter),
|
||||
SCM_EOL);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
|
||||
SCM_CLASSF_PURE_GENERIC);
|
||||
|
|
@ -2428,8 +2434,9 @@ create_standard_classes (void)
|
|||
scm_list_2 (scm_class_accessor,
|
||||
scm_class_extended_generic_with_setter),
|
||||
SCM_EOL);
|
||||
/* <extended-generic> is misplaced. */
|
||||
fix_cpl (scm_class_extended_accessor,
|
||||
scm_class_extended_generic, scm_class_generic);
|
||||
scm_class_extended_generic, scm_class_generic_with_setter);
|
||||
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
|
||||
|
||||
/* Primitive types classes */
|
||||
|
|
|
|||
|
|
@ -400,7 +400,7 @@ install_locale (scm_t_locale locale)
|
|||
account. */
|
||||
category_mask |= locale->category_mask;
|
||||
|
||||
if (locale->base_locale != SCM_UNDEFINED)
|
||||
if (!SCM_UNBNDP (locale->base_locale))
|
||||
locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
|
||||
else
|
||||
locale = NULL;
|
||||
|
|
|
|||
|
|
@ -270,7 +270,10 @@ scm_init_load_path ()
|
|||
else if (env)
|
||||
cpath = scm_parse_path (scm_from_locale_string (env), cpath);
|
||||
else
|
||||
cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
|
||||
{
|
||||
cpath = scm_list_2 (scm_from_locale_string (SCM_CCACHE_DIR),
|
||||
scm_from_locale_string (SCM_SITE_CCACHE_DIR));
|
||||
}
|
||||
|
||||
#endif /* SCM_LIBRARY_DIR */
|
||||
|
||||
|
|
@ -793,6 +796,22 @@ scm_try_auto_compile (SCM source)
|
|||
NULL, NULL);
|
||||
}
|
||||
|
||||
/* See also (system base compile):compiled-file-name. */
|
||||
static SCM
|
||||
canonical_to_suffix (SCM canon)
|
||||
{
|
||||
size_t len = scm_c_string_length (canon);
|
||||
|
||||
if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
|
||||
return canon;
|
||||
else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':')))
|
||||
return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"),
|
||||
scm_c_substring (canon, 0, 1),
|
||||
scm_c_substring (canon, 2, len)));
|
||||
else
|
||||
return canon;
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
|
||||
(SCM args),
|
||||
"Search @var{%load-path} for the file named @var{filename} and\n"
|
||||
|
|
@ -857,7 +876,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
|
|||
{
|
||||
SCM fallback = scm_string_append
|
||||
(scm_list_3 (*scm_loc_compile_fallback_path,
|
||||
full_filename,
|
||||
canonical_to_suffix (full_filename),
|
||||
scm_car (*scm_loc_load_compiled_extensions)));
|
||||
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
|
||||
{
|
||||
|
|
@ -895,7 +914,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
|
|||
{
|
||||
SCM fallback = scm_string_append
|
||||
(scm_list_3 (*scm_loc_compile_fallback_path,
|
||||
full_filename,
|
||||
canonical_to_suffix (full_filename),
|
||||
scm_car (*scm_loc_load_compiled_extensions)));
|
||||
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
|
||||
&& compiled_is_fresh (full_filename, fallback))
|
||||
|
|
|
|||
|
|
@ -294,41 +294,48 @@ resolve_duplicate_binding (SCM module, SCM sym,
|
|||
SCM iface1, SCM var1,
|
||||
SCM iface2, SCM var2)
|
||||
{
|
||||
SCM args[8];
|
||||
SCM handlers;
|
||||
SCM result = SCM_BOOL_F;
|
||||
|
||||
if (!scm_is_eq (var1, var2))
|
||||
{
|
||||
SCM val1, val2;
|
||||
SCM handlers, h, handler_args;
|
||||
if (scm_is_eq (var1, var2))
|
||||
return var1;
|
||||
|
||||
val1 = SCM_VARIABLE_REF (var1);
|
||||
val2 = SCM_VARIABLE_REF (var2);
|
||||
|
||||
val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
|
||||
val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
|
||||
args[0] = module;
|
||||
args[1] = sym;
|
||||
args[2] = iface1;
|
||||
args[3] = SCM_VARIABLE_REF (var1);
|
||||
if (SCM_UNBNDP (args[3]))
|
||||
args[3] = SCM_BOOL_F;
|
||||
args[4] = iface2;
|
||||
args[5] = SCM_VARIABLE_REF (var2);
|
||||
if (SCM_UNBNDP (args[5]))
|
||||
args[5] = SCM_BOOL_F;
|
||||
args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F);
|
||||
args[7] = SCM_BOOL_F;
|
||||
|
||||
handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
|
||||
if (scm_is_false (handlers))
|
||||
handlers = default_duplicate_binding_handlers ();
|
||||
|
||||
handler_args = scm_list_n (module, sym,
|
||||
iface1, val1, iface2, val2,
|
||||
var1, val1,
|
||||
SCM_UNDEFINED);
|
||||
|
||||
for (h = handlers;
|
||||
scm_is_pair (h) && scm_is_false (result);
|
||||
h = SCM_CDR (h))
|
||||
for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers))
|
||||
{
|
||||
result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
|
||||
if (scm_is_true (args[6]))
|
||||
{
|
||||
args[7] = SCM_VARIABLE_REF (args[6]);
|
||||
if (SCM_UNBNDP (args[7]))
|
||||
args[7] = SCM_BOOL_F;
|
||||
}
|
||||
}
|
||||
else
|
||||
result = var1;
|
||||
|
||||
result = scm_call_n (SCM_CAR (handlers), args, 8);
|
||||
|
||||
if (scm_is_true (result))
|
||||
return result;
|
||||
}
|
||||
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
/* No lock is needed for access to this variable, as there are no
|
||||
threads before modules are booted. */
|
||||
SCM scm_pre_modules_obarray;
|
||||
|
|
@ -371,6 +378,12 @@ module_imported_variable (SCM module, SCM sym)
|
|||
found_var = resolve_duplicate_binding (module, sym,
|
||||
found_iface, found_var,
|
||||
iface, var);
|
||||
|
||||
/* Note that it could be that FOUND_VAR doesn't belong
|
||||
either to FOUND_IFACE or to IFACE, if it was created
|
||||
by merge-generics. The right thing to do there would
|
||||
be to treat the import obarray as the iface, but the
|
||||
import obarray isn't actually a module. Oh well. */
|
||||
if (scm_is_eq (found_var, var))
|
||||
found_iface = iface;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -376,8 +376,12 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
|
|||
return SCM_EOL;
|
||||
|
||||
scm_ungetc (c, port);
|
||||
if (scm_is_eq (scm_sym_dot,
|
||||
(tmp = scm_read_expression (port))))
|
||||
tmp = scm_read_expression (port);
|
||||
|
||||
/* Note that it is possible for scm_read_expression to return
|
||||
scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So
|
||||
check that it's a real dot by checking `c'. */
|
||||
if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
|
||||
{
|
||||
ans = scm_read_expression (port);
|
||||
if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
|
||||
|
|
@ -401,7 +405,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
|
|||
scm_ungetc (c, port);
|
||||
tmp = scm_read_expression (port);
|
||||
|
||||
if (scm_is_eq (scm_sym_dot, tmp))
|
||||
/* See above note about scm_sym_dot. */
|
||||
if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
|
||||
{
|
||||
SCM_SETCDR (tl, tmp = scm_read_expression (port));
|
||||
|
||||
|
|
|
|||
|
|
@ -692,6 +692,10 @@ on_thread_exit (void *v)
|
|||
/* This handler is executed in non-guile mode. */
|
||||
scm_i_thread *t = (scm_i_thread *) v, **tp;
|
||||
|
||||
/* If we were canceled, we were unable to clear `t->guile_mode', so do
|
||||
it here. */
|
||||
t->guile_mode = 0;
|
||||
|
||||
/* If this thread was cancelled while doing a cond wait, it will
|
||||
still have a mutex locked, so we unlock it here. */
|
||||
if (t->held_mutex)
|
||||
|
|
@ -831,12 +835,6 @@ scm_init_guile ()
|
|||
}
|
||||
}
|
||||
|
||||
SCM_UNUSED static void
|
||||
scm_leave_guile_cleanup (void *x)
|
||||
{
|
||||
on_thread_exit (SCM_I_CURRENT_THREAD);
|
||||
}
|
||||
|
||||
struct with_guile_args
|
||||
{
|
||||
GC_fn_type func;
|
||||
|
|
@ -1368,7 +1366,9 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
|
|||
{
|
||||
scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
|
||||
|
||||
scm_i_pthread_mutex_unlock (&m->lock);
|
||||
/* FIXME: The order in which `t->admin_mutex' and
|
||||
`m->lock' are taken differs from that in
|
||||
`on_thread_exit', potentially leading to deadlocks. */
|
||||
scm_i_pthread_mutex_lock (&t->admin_mutex);
|
||||
|
||||
/* Only keep a weak reference to MUTEX so that it's not
|
||||
|
|
@ -1379,7 +1379,6 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
|
|||
t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
|
||||
|
||||
scm_i_pthread_mutex_unlock (&t->admin_mutex);
|
||||
scm_i_pthread_mutex_lock (&m->lock);
|
||||
}
|
||||
*ret = 1;
|
||||
break;
|
||||
|
|
@ -1458,6 +1457,9 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0,
|
|||
waittime = &cwaittime;
|
||||
}
|
||||
|
||||
if (!SCM_UNBNDP (owner) && !scm_is_false (owner))
|
||||
SCM_VALIDATE_THREAD (3, owner);
|
||||
|
||||
exception = fat_mutex_lock (m, waittime, owner, &ret);
|
||||
if (!scm_is_false (exception))
|
||||
scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1);
|
||||
|
|
|
|||
|
|
@ -61,23 +61,31 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
|
|||
SCM finish_args; /* used both for returns: both in error
|
||||
and normal situations */
|
||||
#ifdef HAVE_LABELS_AS_VALUES
|
||||
static void **jump_table = NULL;
|
||||
static const void **jump_table_pointer = NULL;
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_LABELS_AS_VALUES
|
||||
if (SCM_UNLIKELY (!jump_table))
|
||||
register const void **jump_table JT_REG;
|
||||
|
||||
if (SCM_UNLIKELY (!jump_table_pointer))
|
||||
{
|
||||
int i;
|
||||
jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*));
|
||||
jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
|
||||
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
|
||||
jump_table[i] = &&vm_error_bad_instruction;
|
||||
jump_table_pointer[i] = &&vm_error_bad_instruction;
|
||||
#define VM_INSTRUCTION_TO_LABEL 1
|
||||
#define jump_table jump_table_pointer
|
||||
#include <libguile/vm-expand.h>
|
||||
#include <libguile/vm-i-system.i>
|
||||
#include <libguile/vm-i-scheme.i>
|
||||
#include <libguile/vm-i-loader.i>
|
||||
#undef jump_table
|
||||
#undef VM_INSTRUCTION_TO_LABEL
|
||||
}
|
||||
|
||||
/* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
|
||||
load instruction at each instruction dispatch. */
|
||||
jump_table = jump_table_pointer;
|
||||
#endif
|
||||
|
||||
/* Initialization */
|
||||
|
|
|
|||
|
|
@ -57,6 +57,11 @@
|
|||
/* too few registers! because of register allocation errors with various gcs,
|
||||
just punt on explicit assignments on i386, hoping that the "register"
|
||||
declaration will be sufficient. */
|
||||
#elif defined __x86_64__
|
||||
/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
|
||||
well. Tell it to keep the jump table in a r12, which is
|
||||
callee-saved. */
|
||||
#define JT_REG asm ("r12")
|
||||
#endif
|
||||
#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
|
||||
#define IP_REG asm("26")
|
||||
|
|
@ -89,6 +94,9 @@
|
|||
#ifndef FP_REG
|
||||
#define FP_REG
|
||||
#endif
|
||||
#ifndef JT_REG
|
||||
#define JT_REG
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
|
|
|
|||
79
m4/alloca.m4
79
m4/alloca.m4
|
|
@ -1,4 +1,4 @@
|
|||
# alloca.m4 serial 11
|
||||
# alloca.m4 serial 12
|
||||
dnl Copyright (C) 2002-2004, 2006-2007, 2009-2011 Free Software Foundation,
|
||||
dnl Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
|
|
@ -42,3 +42,80 @@ AC_DEFUN([gl_FUNC_ALLOCA],
|
|||
# Prerequisites of lib/alloca.c.
|
||||
# STACK_DIRECTION is already handled by AC_FUNC_ALLOCA.
|
||||
AC_DEFUN([gl_PREREQ_ALLOCA], [:])
|
||||
|
||||
# This works around a bug in autoconf <= 2.68.
|
||||
# See <http://lists.gnu.org/archive/html/bug-gnulib/2011-06/msg00277.html>.
|
||||
|
||||
m4_version_prereq([2.69], [] ,[
|
||||
|
||||
# This is taken from the following Autoconf patch:
|
||||
# http://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=6cd9f12520b0d6f76d3230d7565feba1ecf29497
|
||||
|
||||
# _AC_LIBOBJ_ALLOCA
|
||||
# -----------------
|
||||
# Set up the LIBOBJ replacement of `alloca'. Well, not exactly
|
||||
# AC_LIBOBJ since we actually set the output variable `ALLOCA'.
|
||||
# Nevertheless, for Automake, AC_LIBSOURCES it.
|
||||
m4_define([_AC_LIBOBJ_ALLOCA],
|
||||
[# The SVR3 libPW and SVR4 libucb both contain incompatible functions
|
||||
# that cause trouble. Some versions do not even contain alloca or
|
||||
# contain a buggy version. If you still want to use their alloca,
|
||||
# use ar to extract alloca.o from them instead of compiling alloca.c.
|
||||
AC_LIBSOURCES(alloca.c)
|
||||
AC_SUBST([ALLOCA], [\${LIBOBJDIR}alloca.$ac_objext])dnl
|
||||
AC_DEFINE(C_ALLOCA, 1, [Define to 1 if using `alloca.c'.])
|
||||
|
||||
AC_CACHE_CHECK(whether `alloca.c' needs Cray hooks, ac_cv_os_cray,
|
||||
[AC_EGREP_CPP(webecray,
|
||||
[#if defined CRAY && ! defined CRAY2
|
||||
webecray
|
||||
#else
|
||||
wenotbecray
|
||||
#endif
|
||||
], ac_cv_os_cray=yes, ac_cv_os_cray=no)])
|
||||
if test $ac_cv_os_cray = yes; then
|
||||
for ac_func in _getb67 GETB67 getb67; do
|
||||
AC_CHECK_FUNC($ac_func,
|
||||
[AC_DEFINE_UNQUOTED(CRAY_STACKSEG_END, $ac_func,
|
||||
[Define to one of `_getb67', `GETB67',
|
||||
`getb67' for Cray-2 and Cray-YMP
|
||||
systems. This function is required for
|
||||
`alloca.c' support on those systems.])
|
||||
break])
|
||||
done
|
||||
fi
|
||||
|
||||
AC_CACHE_CHECK([stack direction for C alloca],
|
||||
[ac_cv_c_stack_direction],
|
||||
[AC_RUN_IFELSE([AC_LANG_SOURCE(
|
||||
[AC_INCLUDES_DEFAULT
|
||||
int
|
||||
find_stack_direction (int *addr, int depth)
|
||||
{
|
||||
int dir, dummy = 0;
|
||||
if (! addr)
|
||||
addr = &dummy;
|
||||
*addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1;
|
||||
dir = depth ? find_stack_direction (addr, depth - 1) : 0;
|
||||
return dir + dummy;
|
||||
}
|
||||
|
||||
int
|
||||
main (int argc, char **argv)
|
||||
{
|
||||
return find_stack_direction (0, argc + !argv + 20) < 0;
|
||||
}])],
|
||||
[ac_cv_c_stack_direction=1],
|
||||
[ac_cv_c_stack_direction=-1],
|
||||
[ac_cv_c_stack_direction=0])])
|
||||
AH_VERBATIM([STACK_DIRECTION],
|
||||
[/* If using the C implementation of alloca, define if you know the
|
||||
direction of stack growth for your system; otherwise it will be
|
||||
automatically deduced at runtime.
|
||||
STACK_DIRECTION > 0 => grows toward higher addresses
|
||||
STACK_DIRECTION < 0 => grows toward lower addresses
|
||||
STACK_DIRECTION = 0 => direction of growth unknown */
|
||||
@%:@undef STACK_DIRECTION])dnl
|
||||
AC_DEFINE_UNQUOTED(STACK_DIRECTION, $ac_cv_c_stack_direction)
|
||||
])# _AC_LIBOBJ_ALLOCA
|
||||
])
|
||||
|
|
|
|||
16
m4/ceil.m4
16
m4/ceil.m4
|
|
@ -1,4 +1,4 @@
|
|||
# ceil.m4 serial 6
|
||||
# ceil.m4 serial 8
|
||||
dnl Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
|
|
@ -28,12 +28,18 @@ AC_DEFUN([gl_FUNC_CEIL],
|
|||
#include <math.h>
|
||||
]gl_DOUBLE_MINUS_ZERO_CODE[
|
||||
]gl_DOUBLE_SIGNBIT_CODE[
|
||||
int main()
|
||||
static double dummy (double f) { return 0; }
|
||||
int main (int argc, char *argv[])
|
||||
{
|
||||
double (*my_ceil) (double) = argc ? ceil : dummy;
|
||||
int result = 0;
|
||||
/* Test whether ceil (-0.0) is -0.0. */
|
||||
if (signbitd (minus_zerod) && !signbitd (ceil (minus_zerod)))
|
||||
return 1;
|
||||
return 0;
|
||||
if (signbitd (minus_zerod) && !signbitd (my_ceil (minus_zerod)))
|
||||
result |= 1;
|
||||
/* Test whether ceil (-0.3) is -0.0. */
|
||||
if (signbitd (-0.3) && !signbitd (my_ceil (-0.3)))
|
||||
result |= 2;
|
||||
return result;
|
||||
}
|
||||
]])],
|
||||
[gl_cv_func_ceil_ieee=yes],
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# float_h.m4 serial 6
|
||||
# float_h.m4 serial 7
|
||||
dnl Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
|
|
@ -9,12 +9,41 @@ AC_DEFUN([gl_FLOAT_H],
|
|||
AC_REQUIRE([AC_PROG_CC])
|
||||
AC_REQUIRE([AC_CANONICAL_HOST])
|
||||
FLOAT_H=
|
||||
REPLACE_FLOAT_LDBL=0
|
||||
case "$host_os" in
|
||||
beos* | openbsd* | mirbsd*)
|
||||
aix* | beos* | openbsd* | mirbsd* | irix*)
|
||||
FLOAT_H=float.h
|
||||
gl_NEXT_HEADERS([float.h])
|
||||
;;
|
||||
freebsd*)
|
||||
case "$host_cpu" in
|
||||
changequote(,)dnl
|
||||
i[34567]86 )
|
||||
changequote([,])dnl
|
||||
FLOAT_H=float.h
|
||||
;;
|
||||
x86_64 )
|
||||
# On x86_64 systems, the C compiler may still be generating
|
||||
# 32-bit code.
|
||||
AC_EGREP_CPP([yes],
|
||||
[#if defined __LP64__ || defined __x86_64__ || defined __amd64__
|
||||
yes
|
||||
#endif],
|
||||
[],
|
||||
[FLOAT_H=float.h])
|
||||
;;
|
||||
esac
|
||||
;;
|
||||
esac
|
||||
case "$host_os" in
|
||||
aix* | freebsd*)
|
||||
if test -n "$FLOAT_H"; then
|
||||
REPLACE_FLOAT_LDBL=1
|
||||
fi
|
||||
;;
|
||||
esac
|
||||
if test -n "$FLOAT_H"; then
|
||||
gl_NEXT_HEADERS([float.h])
|
||||
fi
|
||||
AC_SUBST([FLOAT_H])
|
||||
AM_CONDITIONAL([GL_GENERATE_FLOAT_H], [test -n "$FLOAT_H"])
|
||||
])
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# floor.m4 serial 6
|
||||
# floor.m4 serial 7
|
||||
dnl Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
|
|
@ -28,10 +28,12 @@ AC_DEFUN([gl_FUNC_FLOOR],
|
|||
#include <math.h>
|
||||
]gl_DOUBLE_MINUS_ZERO_CODE[
|
||||
]gl_DOUBLE_SIGNBIT_CODE[
|
||||
int main()
|
||||
static double dummy (double f) { return 0; }
|
||||
int main (int argc, char *argv[])
|
||||
{
|
||||
double (*my_floor) (double) = argc ? floor : dummy;
|
||||
/* Test whether floor (-0.0) is -0.0. */
|
||||
if (signbitd (minus_zerod) && !signbitd (floor (minus_zerod)))
|
||||
if (signbitd (minus_zerod) && !signbitd (my_floor (minus_zerod)))
|
||||
return 1;
|
||||
return 0;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -257,6 +257,9 @@ fi
|
|||
gl_MODULE_INDICATOR([fflush])
|
||||
gl_STDIO_MODULE_INDICATOR([fflush])
|
||||
gl_FLOAT_H
|
||||
if test $REPLACE_FLOAT_LDBL = 1; then
|
||||
AC_LIBOBJ([float])
|
||||
fi
|
||||
gl_FUNC_FLOCK
|
||||
if test $HAVE_FLOCK = 0; then
|
||||
AC_LIBOBJ([flock])
|
||||
|
|
@ -778,6 +781,7 @@ AC_DEFUN([gl_FILE_LIST], [
|
|||
lib/fd-hook.h
|
||||
lib/fflush.c
|
||||
lib/float+.h
|
||||
lib/float.c
|
||||
lib/float.in.h
|
||||
lib/flock.c
|
||||
lib/floor.c
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# isinf.m4 serial 4
|
||||
# isinf.m4 serial 5
|
||||
dnl Copyright (C) 2007-2011 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,7 +11,7 @@ AC_DEFUN([gl_ISINF],
|
|||
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
|
||||
AC_CHECK_DECLS([isinf], , , [#include <math.h>])
|
||||
if test "$ac_cv_have_decl_isinf" = yes; then
|
||||
gl_CHECK_MATH_LIB([ISINF_LIBM], [x = isinf (x);])
|
||||
gl_CHECK_MATH_LIB([ISINF_LIBM], [x = isinf (x) + isinf ((float) x);])
|
||||
if test "$ISINF_LIBM" != missing; then
|
||||
dnl Test whether isinf() on 'long double' works.
|
||||
gl_ISINFL_WORKS
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# serial 22
|
||||
# serial 23
|
||||
|
||||
# Copyright (C) 1997-2001, 2003-2011 Free Software Foundation, Inc.
|
||||
#
|
||||
|
|
@ -15,7 +15,7 @@ AC_DEFUN([gl_FUNC_LSTAT],
|
|||
dnl "#define lstat stat", and lstat.c is a no-op.
|
||||
AC_CHECK_FUNCS_ONCE([lstat])
|
||||
if test $ac_cv_func_lstat = yes; then
|
||||
AC_REQUIRE([AC_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
|
||||
AC_REQUIRE([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
|
||||
if test $gl_cv_func_lstat_dereferences_slashed_symlink = no; then
|
||||
REPLACE_LSTAT=1
|
||||
fi
|
||||
|
|
|
|||
|
|
@ -27,18 +27,18 @@ AC_DEFUN([gl_FUNC_MMAP_ANON],
|
|||
gl_have_mmap_anonymous=no
|
||||
if test $gl_have_mmap = yes; then
|
||||
AC_MSG_CHECKING([for MAP_ANONYMOUS])
|
||||
AC_EGREP_CPP([I cant identify this map.], [
|
||||
AC_EGREP_CPP([I cant identify this map], [
|
||||
#include <sys/mman.h>
|
||||
#ifdef MAP_ANONYMOUS
|
||||
I cant identify this map.
|
||||
I cant identify this map
|
||||
#endif
|
||||
],
|
||||
[gl_have_mmap_anonymous=yes])
|
||||
if test $gl_have_mmap_anonymous != yes; then
|
||||
AC_EGREP_CPP([I cant identify this map.], [
|
||||
AC_EGREP_CPP([I cant identify this map], [
|
||||
#include <sys/mman.h>
|
||||
#ifdef MAP_ANON
|
||||
I cant identify this map.
|
||||
I cant identify this map
|
||||
#endif
|
||||
],
|
||||
[AC_DEFINE([MAP_ANONYMOUS], [MAP_ANON],
|
||||
|
|
|
|||
11
m4/printf.m4
11
m4/printf.m4
|
|
@ -1,4 +1,4 @@
|
|||
# printf.m4 serial 42
|
||||
# printf.m4 serial 43
|
||||
dnl Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
|
|
@ -892,7 +892,8 @@ dnl On mingw, precisions larger than 512 are treated like 512, in integer,
|
|||
dnl floating-point or pointer output. On Solaris 10/x86, precisions larger
|
||||
dnl than 510 in floating-point output crash the program. On Solaris 10/SPARC,
|
||||
dnl precisions larger than 510 in floating-point output yield wrong results.
|
||||
dnl On BeOS, precisions larger than 1044 crash the program.
|
||||
dnl On AIX 7.1, precisions larger than 998 in floating-point output yield
|
||||
dnl wrong results. On BeOS, precisions larger than 1044 crash the program.
|
||||
dnl Result is gl_cv_func_printf_precision.
|
||||
|
||||
AC_DEFUN([gl_PRINTF_PRECISION],
|
||||
|
|
@ -921,6 +922,9 @@ int main ()
|
|||
if (sprintf (buf, "%.511f %d", 1.0, 33, 44) < 511 + 5
|
||||
|| buf[0] != '1')
|
||||
result |= 4;
|
||||
if (sprintf (buf, "%.999f %d", 1.0, 33, 44) < 999 + 5
|
||||
|| buf[0] != '1')
|
||||
result |= 4;
|
||||
return result;
|
||||
}]])],
|
||||
[gl_cv_func_printf_precision=yes],
|
||||
|
|
@ -1465,7 +1469,8 @@ dnl Solaris 11 2010-11 . . # # # . . # . . . # . . .
|
|||
dnl Solaris 10 . . # # # . . # . . . # # . . . . . . .
|
||||
dnl Solaris 2.6 ... 9 # . # # # # . # . . . # # . . . # . . .
|
||||
dnl Solaris 2.5.1 # . # # # # . # . . . # . . # # # # # #
|
||||
dnl AIX 5.2, 7.1 . . # # # . . . . . . # . . . . . . . .
|
||||
dnl AIX 7.1 . . # # # . . . . . . # # . . . . . . .
|
||||
dnl AIX 5.2 . . # # # . . . . . . # . . . . . . . .
|
||||
dnl AIX 4.3.2, 5.1 # . # # # # . . . . . # . . . . # . . .
|
||||
dnl HP-UX 11.31 . . . . # . . . . . . # . . . . # # . .
|
||||
dnl HP-UX 11.{00,11,23} # . . . # # . . . . . # . . . . # # . #
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# trunc.m4 serial 6
|
||||
# trunc.m4 serial 7
|
||||
dnl Copyright (C) 2007, 2010-2011 Free Software Foundation, Inc.
|
||||
dnl This file is free software; the Free Software Foundation
|
||||
dnl gives unlimited permission to copy and/or distribute it,
|
||||
|
|
@ -56,10 +56,12 @@ AC_DEFUN([gl_FUNC_TRUNC],
|
|||
#include <math.h>
|
||||
]gl_DOUBLE_MINUS_ZERO_CODE[
|
||||
]gl_DOUBLE_SIGNBIT_CODE[
|
||||
int main()
|
||||
static double dummy (double f) { return 0; }
|
||||
int main (int argc, char *argv[])
|
||||
{
|
||||
double (*my_trunc) (double) = argc ? trunc : dummy;
|
||||
/* Test whether trunc (-0.0) is -0.0. */
|
||||
if (signbitd (minus_zerod) && !signbitd (trunc (minus_zerod)))
|
||||
if (signbitd (minus_zerod) && !signbitd (my_trunc (minus_zerod)))
|
||||
return 1;
|
||||
return 0;
|
||||
}
|
||||
|
|
|
|||
79
maint.mk
79
maint.mk
|
|
@ -405,11 +405,11 @@ sc_prohibit_HAVE_MBRTOWC:
|
|||
$(_sc_search_regexp)
|
||||
|
||||
# To use this "command" macro, you must first define two shell variables:
|
||||
# h: the header, enclosed in <> or ""
|
||||
# h: the header name, with no enclosing <> or ""
|
||||
# re: a regular expression that matches IFF something provided by $h is used.
|
||||
define _sc_header_without_use
|
||||
dummy=; : so we do not need a semicolon before each use; \
|
||||
h_esc=`echo "$$h"|sed 's/\./\\\\./g'`; \
|
||||
h_esc=`echo '[<"]'"$$h"'[">]'|sed 's/\./\\\\./g'`; \
|
||||
if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \
|
||||
files=$$(grep -l '^# *include '"$$h_esc" \
|
||||
$$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \
|
||||
|
|
@ -422,42 +422,42 @@ endef
|
|||
|
||||
# Prohibit the inclusion of assert.h without an actual use of assert.
|
||||
sc_prohibit_assert_without_use:
|
||||
@h='<assert.h>' re='\<assert *\(' $(_sc_header_without_use)
|
||||
@h='assert.h' re='\<assert *\(' $(_sc_header_without_use)
|
||||
|
||||
# Prohibit the inclusion of close-stream.h without an actual use.
|
||||
sc_prohibit_close_stream_without_use:
|
||||
@h='"close-stream.h"' re='\<close_stream *\(' $(_sc_header_without_use)
|
||||
@h='close-stream.h' re='\<close_stream *\(' $(_sc_header_without_use)
|
||||
|
||||
# Prohibit the inclusion of getopt.h without an actual use.
|
||||
sc_prohibit_getopt_without_use:
|
||||
@h='<getopt.h>' re='\<getopt(_long)? *\(' $(_sc_header_without_use)
|
||||
@h='getopt.h' re='\<getopt(_long)? *\(' $(_sc_header_without_use)
|
||||
|
||||
# Don't include quotearg.h unless you use one of its functions.
|
||||
sc_prohibit_quotearg_without_use:
|
||||
@h='"quotearg.h"' re='\<quotearg(_[^ ]+)? *\(' $(_sc_header_without_use)
|
||||
@h='quotearg.h' re='\<quotearg(_[^ ]+)? *\(' $(_sc_header_without_use)
|
||||
|
||||
# Don't include quote.h unless you use one of its functions.
|
||||
sc_prohibit_quote_without_use:
|
||||
@h='"quote.h"' re='\<quote(_n)? *\(' $(_sc_header_without_use)
|
||||
@h='quote.h' re='\<quote(_n)? *\(' $(_sc_header_without_use)
|
||||
|
||||
# Don't include this header unless you use one of its functions.
|
||||
sc_prohibit_long_options_without_use:
|
||||
@h='"long-options.h"' re='\<parse_long_options *\(' \
|
||||
@h='long-options.h' re='\<parse_long_options *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Don't include this header unless you use one of its functions.
|
||||
sc_prohibit_inttostr_without_use:
|
||||
@h='"inttostr.h"' re='\<(off|[iu]max|uint)tostr *\(' \
|
||||
@h='inttostr.h' re='\<(off|[iu]max|uint)tostr *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Don't include this header unless you use one of its functions.
|
||||
sc_prohibit_ignore_value_without_use:
|
||||
@h='"ignore-value.h"' re='\<ignore_(value|ptr) *\(' \
|
||||
@h='ignore-value.h' re='\<ignore_(value|ptr) *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Don't include this header unless you use one of its functions.
|
||||
sc_prohibit_error_without_use:
|
||||
@h='"error.h"' \
|
||||
@h='error.h' \
|
||||
re='\<error(_at_line|_print_progname|_one_per_line|_message_count)? *\('\
|
||||
$(_sc_header_without_use)
|
||||
|
||||
|
|
@ -480,7 +480,7 @@ sc_prohibit_error_without_use:
|
|||
_xa1 = x(((2n?)?re|char|n(re|m)|[cmz])alloc|alloc_(oversized|die)|(mem|str)dup)
|
||||
_xa2 = X([CZ]|N?M)ALLOC
|
||||
sc_prohibit_xalloc_without_use:
|
||||
@h='"xalloc.h"' \
|
||||
@h='xalloc.h' \
|
||||
re='\<($(_xa1)|$(_xa2)) *\('\
|
||||
$(_sc_header_without_use)
|
||||
|
||||
|
|
@ -491,46 +491,46 @@ clear|delete|free|get_(first|next)|insert|lookup|print_statistics|reset_tuning
|
|||
_hash_fn = \<($(_hash_re)) *\(
|
||||
_hash_struct = (struct )?\<[Hh]ash_(table|tuning)\>
|
||||
sc_prohibit_hash_without_use:
|
||||
@h='"hash.h"' \
|
||||
@h='hash.h' \
|
||||
re='$(_hash_fn)|$(_hash_struct)'\
|
||||
$(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_cloexec_without_use:
|
||||
@h='"cloexec.h"' re='\<(set_cloexec_flag|dup_cloexec) *\(' \
|
||||
@h='cloexec.h' re='\<(set_cloexec_flag|dup_cloexec) *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_posixver_without_use:
|
||||
@h='"posixver.h"' re='\<posix2_version *\(' $(_sc_header_without_use)
|
||||
@h='posixver.h' re='\<posix2_version *\(' $(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_same_without_use:
|
||||
@h='"same.h"' re='\<same_name *\(' $(_sc_header_without_use)
|
||||
@h='same.h' re='\<same_name *\(' $(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_hash_pjw_without_use:
|
||||
@h='"hash-pjw.h"' \
|
||||
@h='hash-pjw.h' \
|
||||
re='\<hash_pjw *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_safe_read_without_use:
|
||||
@h='"safe-read.h"' re='(\<SAFE_READ_ERROR\>|\<safe_read *\()' \
|
||||
@h='safe-read.h' re='(\<SAFE_READ_ERROR\>|\<safe_read *\()' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_argmatch_without_use:
|
||||
@h='"argmatch.h"' \
|
||||
@h='argmatch.h' \
|
||||
re='(\<(ARRAY_CARDINALITY|X?ARGMATCH(|_TO_ARGUMENT|_VERIFY))\>|\<argmatch(_exit_fn|_(in)?valid) *\()' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_canonicalize_without_use:
|
||||
@h='"canonicalize.h"' \
|
||||
@h='canonicalize.h' \
|
||||
re='CAN_(EXISTING|ALL_BUT_LAST|MISSING)|canonicalize_(mode_t|filename_mode)' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_root_dev_ino_without_use:
|
||||
@h='"root-dev-ino.h"' \
|
||||
@h='root-dev-ino.h' \
|
||||
re='(\<ROOT_DEV_INO_(CHECK|WARN)\>|\<get_root_dev_ino *\()' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
sc_prohibit_openat_without_use:
|
||||
@h='"openat.h"' \
|
||||
@h='openat.h' \
|
||||
re='\<(openat_(permissive|needs_fchdir|(save|restore)_fail)|l?(stat|ch(own|mod))at|(euid)?accessat)\>' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
|
|
@ -538,7 +538,7 @@ sc_prohibit_openat_without_use:
|
|||
ctype_re = isalnum|isalpha|isascii|isblank|iscntrl|isdigit|isgraph|islower\
|
||||
|isprint|ispunct|isspace|isupper|isxdigit|tolower|toupper
|
||||
sc_prohibit_c_ctype_without_use:
|
||||
@h='[<"]c-ctype.h[">]' re='\<c_($(ctype_re)) *\(' \
|
||||
@h='c-ctype.h' re='\<c_($(ctype_re)) *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
_empty =
|
||||
|
|
@ -574,50 +574,56 @@ _sig_syms_re = $(subst $(_sp),|,$(strip $(_sig_names) $(_sig_types_and_consts)))
|
|||
|
||||
# Prohibit the inclusion of signal.h without an actual use.
|
||||
sc_prohibit_signal_without_use:
|
||||
@h='<signal.h>' \
|
||||
@h='signal.h' \
|
||||
re='\<($(_sig_function_re)) *\(|\<($(_sig_syms_re))\>' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Don't include stdio--.h unless you use one of its functions.
|
||||
sc_prohibit_stdio--_without_use:
|
||||
@h='"stdio--.h"' re='\<((f(re)?|p)open|tmpfile) *\(' \
|
||||
@h='stdio--.h' re='\<((f(re)?|p)open|tmpfile) *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Don't include stdio-safer.h unless you use one of its functions.
|
||||
sc_prohibit_stdio-safer_without_use:
|
||||
@h='"stdio-safer.h"' re='\<((f(re)?|p)open|tmpfile)_safer *\(' \
|
||||
@h='stdio-safer.h' re='\<((f(re)?|p)open|tmpfile)_safer *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Prohibit the inclusion of strings.h without a sensible use.
|
||||
# Using the likes of bcmp, bcopy, bzero, index or rindex is not sensible.
|
||||
sc_prohibit_strings_without_use:
|
||||
@h='<strings.h>' \
|
||||
@h='strings.h' \
|
||||
re='\<(strn?casecmp|ffs(ll)?)\>' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Get the list of symbol names with this:
|
||||
# perl -lne '/^# *define (\w+)\(/ and print $1' lib/intprops.h|grep -v '^s'|fmt
|
||||
# perl -lne '/^# *define ([A-Z]\w+)\(/ and print $1' lib/intprops.h|fmt
|
||||
_intprops_names = \
|
||||
TYPE_IS_INTEGER TYPE_TWOS_COMPLEMENT TYPE_ONES_COMPLEMENT \
|
||||
TYPE_SIGNED_MAGNITUDE TYPE_SIGNED TYPE_MINIMUM TYPE_MAXIMUM \
|
||||
INT_STRLEN_BOUND INT_BUFSIZE_BOUND
|
||||
INT_BITS_STRLEN_BOUND INT_STRLEN_BOUND INT_BUFSIZE_BOUND \
|
||||
INT_ADD_RANGE_OVERFLOW INT_SUBTRACT_RANGE_OVERFLOW \
|
||||
INT_NEGATE_RANGE_OVERFLOW INT_MULTIPLY_RANGE_OVERFLOW \
|
||||
INT_DIVIDE_RANGE_OVERFLOW INT_REMAINDER_RANGE_OVERFLOW \
|
||||
INT_LEFT_SHIFT_RANGE_OVERFLOW INT_ADD_OVERFLOW INT_SUBTRACT_OVERFLOW \
|
||||
INT_NEGATE_OVERFLOW INT_MULTIPLY_OVERFLOW INT_DIVIDE_OVERFLOW \
|
||||
INT_REMAINDER_OVERFLOW INT_LEFT_SHIFT_OVERFLOW
|
||||
_intprops_syms_re = $(subst $(_sp),|,$(strip $(_intprops_names)))
|
||||
# Prohibit the inclusion of intprops.h without an actual use.
|
||||
sc_prohibit_intprops_without_use:
|
||||
@h='"intprops.h"' \
|
||||
@h='intprops.h' \
|
||||
re='\<($(_intprops_syms_re)) *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
_stddef_syms_re = NULL|offsetof|ptrdiff_t|size_t|wchar_t
|
||||
# Prohibit the inclusion of stddef.h without an actual use.
|
||||
sc_prohibit_stddef_without_use:
|
||||
@h='<stddef.h>' \
|
||||
@h='stddef.h' \
|
||||
re='\<($(_stddef_syms_re)) *\(' \
|
||||
$(_sc_header_without_use)
|
||||
|
||||
# Don't include xfreopen.h unless you use one of its functions.
|
||||
sc_prohibit_xfreopen_without_use:
|
||||
@h='"xfreopen.h"' re='\<xfreopen *\(' $(_sc_header_without_use)
|
||||
@h='xfreopen.h' re='\<xfreopen *\(' $(_sc_header_without_use)
|
||||
|
||||
sc_obsolete_symbols:
|
||||
@prohibit='\<(HAVE''_FCNTL_H|O''_NDELAY)\>' \
|
||||
|
|
@ -1106,6 +1112,7 @@ sc_copyright_check:
|
|||
# the other init.sh-using tests also get it right.
|
||||
_hv_file ?= $(srcdir)/tests/help-version
|
||||
_hv_regex_weak ?= ^ *\. .*/init\.sh"
|
||||
# Fix syntax-highlighters "
|
||||
_hv_regex_strong ?= ^ *\. "\$${srcdir=\.}/init\.sh"
|
||||
sc_cross_check_PATH_usage_in_tests:
|
||||
@if test -f $(_hv_file); then \
|
||||
|
|
@ -1133,6 +1140,14 @@ sc_Wundef_boolean:
|
|||
halt='Use 0 or 1 for macro values' \
|
||||
$(_sc_search_regexp)
|
||||
|
||||
# Even if you use pathmax.h to guarantee that PATH_MAX is defined, it might
|
||||
# not be constant, or might overflow a stack. In general, use PATH_MAX as
|
||||
# a limit, not an array or alloca size.
|
||||
sc_prohibit_path_max_allocation:
|
||||
@prohibit='(\balloca *\([^)]*|\[[^]]*)PATH_MAX' \
|
||||
halt='Avoid stack allocations of size PATH_MAX' \
|
||||
$(_sc_search_regexp)
|
||||
|
||||
sc_vulnerable_makefile_CVE-2009-4029:
|
||||
@prohibit='perm -777 -exec chmod a\+rwx|chmod 777 \$$\(distdir\)' \
|
||||
in_files=$$(find $(srcdir) -name Makefile.in) \
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
#!/bin/sh
|
||||
# -*- scheme -*-
|
||||
exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
|
||||
prefix="@prefix@"
|
||||
exec_prefix="@exec_prefix@"
|
||||
exec ${GUILE:-@bindir@/@guile_program_name@} $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
|
||||
!#
|
||||
|
||||
;;;; guild --- running scripts bundled with Guile
|
||||
|
|
@ -25,6 +27,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
|
|||
|
||||
(define-module (guild)
|
||||
#:use-module (ice-9 getopt-long)
|
||||
#:use-module (ice-9 command-line)
|
||||
#:autoload (ice-9 format) (format))
|
||||
|
||||
;; Hack to provide scripts with the bug-report address.
|
||||
|
|
@ -37,23 +40,11 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
|
|||
'((help (single-char #\h))
|
||||
(version (single-char #\v))))
|
||||
|
||||
(define (display-help)
|
||||
(display "\
|
||||
Usage: guild --version
|
||||
guild --help
|
||||
guild PROGRAM [ARGS]
|
||||
|
||||
If PROGRAM is \"list\" or omitted, display available scripts, otherwise
|
||||
PROGRAM is run with ARGS.
|
||||
"))
|
||||
|
||||
(define (display-version)
|
||||
(format #t "guild (GNU Guile ~A) ~A
|
||||
Copyright (C) 2010 Free Software Foundation, Inc.
|
||||
License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>
|
||||
This is free software: you are free to change and redistribute it.
|
||||
There is NO WARRANTY, to the extent permitted by law.
|
||||
" (version) (effective-version)))
|
||||
(version-etc "@PACKAGE_NAME@"
|
||||
(version)
|
||||
#:command-name "guild"
|
||||
#:license *LGPLv3+*))
|
||||
|
||||
(define (find-script s)
|
||||
(resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
|
||||
|
|
@ -62,20 +53,17 @@ There is NO WARRANTY, to the extent permitted by law.
|
|||
(if (defined? 'setlocale)
|
||||
(setlocale LC_ALL ""))
|
||||
|
||||
(let ((options (getopt-long args *option-grammar*
|
||||
#:stop-at-first-non-option #t)))
|
||||
(let* ((options (getopt-long args *option-grammar*
|
||||
#:stop-at-first-non-option #t))
|
||||
(args (option-ref options '() '())))
|
||||
(cond
|
||||
((option-ref options 'help #f)
|
||||
(display-help)
|
||||
(apply (module-ref (resolve-module '(scripts help)) 'main) args)
|
||||
(exit 0))
|
||||
((option-ref options 'version #f)
|
||||
(display-version)
|
||||
(exit 0))
|
||||
(else
|
||||
(let ((args (option-ref options '() '())))
|
||||
(cond ((find-script (if (null? args)
|
||||
"list"
|
||||
(car args)))
|
||||
((find-script (if (null? args) "help" (car args)))
|
||||
=> (lambda (mod)
|
||||
(exit (apply (module-ref mod 'main) (if (null? args)
|
||||
'()
|
||||
|
|
@ -84,5 +72,5 @@ There is NO WARRANTY, to the extent permitted by law.
|
|||
(format (current-error-port)
|
||||
"guild: unknown script ~s~%" (car args))
|
||||
(format (current-error-port)
|
||||
"Try `guild --help' for more information.~%")
|
||||
(exit 1))))))))
|
||||
"Try `guild help' for more information.~%")
|
||||
(exit 1)))))
|
||||
|
|
|
|||
|
|
@ -136,4 +136,8 @@ if test "x${top_srcdir}" != "x${top_builddir}"; then
|
|||
fi
|
||||
export PATH
|
||||
|
||||
# Define $GUILE, used by `guild'.
|
||||
GUILE="${top_builddir}/meta/guile"
|
||||
export GUILE
|
||||
|
||||
exec "$@"
|
||||
|
|
|
|||
|
|
@ -146,7 +146,6 @@ BRAINFUCK_LANG_SOURCES = \
|
|||
language/brainfuck/spec.scm
|
||||
|
||||
SCRIPTS_SOURCES = \
|
||||
scripts/PROGRAM.scm \
|
||||
scripts/autofrisk.scm \
|
||||
scripts/compile.scm \
|
||||
scripts/disassemble.scm \
|
||||
|
|
@ -154,6 +153,7 @@ SCRIPTS_SOURCES = \
|
|||
scripts/doc-snarf.scm \
|
||||
scripts/frisk.scm \
|
||||
scripts/generate-autoload.scm \
|
||||
scripts/help.scm \
|
||||
scripts/lint.scm \
|
||||
scripts/list.scm \
|
||||
scripts/punify.scm \
|
||||
|
|
@ -356,6 +356,7 @@ LIB_SOURCES = \
|
|||
texinfo/serialize.scm
|
||||
|
||||
WEB_SOURCES = \
|
||||
web/client.scm \
|
||||
web/http.scm \
|
||||
web/request.scm \
|
||||
web/response.scm \
|
||||
|
|
|
|||
|
|
@ -3414,6 +3414,15 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
'(#:warnings (unbound-variable arity-mismatch format)))
|
||||
|
||||
(define* (load-in-vicinity dir path #:optional reader)
|
||||
(define (canonical->suffix canon)
|
||||
(cond
|
||||
((string-prefix? "/" canon) canon)
|
||||
((and (> (string-length canon) 2)
|
||||
(eqv? (string-ref canon 1) #\:))
|
||||
;; Paths like C:... transform to /C...
|
||||
(string-append "/" (substring canon 0 1) (substring canon 2)))
|
||||
(else canon)))
|
||||
|
||||
;; Returns the .go file corresponding to `name'. Does not search load
|
||||
;; paths, only the fallback path. If the .go file is missing or out of
|
||||
;; date, and auto-compilation is enabled, will try auto-compilation, just
|
||||
|
|
@ -3425,11 +3434,12 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
;; partially duplicates functionality from (system base compile).
|
||||
;;
|
||||
(define (compiled-file-name canon-path)
|
||||
;; FIXME: would probably be better just to append SHA1(canon-path)
|
||||
;; to the %compile-fallback-path, to avoid deep directory stats.
|
||||
(and %compile-fallback-path
|
||||
(string-append
|
||||
%compile-fallback-path
|
||||
;; no need for '/' separator here, canon-path is absolute
|
||||
canon-path
|
||||
(canonical->suffix canon-path)
|
||||
(cond ((or (null? %load-compiled-extensions)
|
||||
(string-null? (car %load-compiled-extensions)))
|
||||
(warn "invalid %load-compiled-extensions"
|
||||
|
|
|
|||
|
|
@ -398,13 +398,11 @@
|
|||
names))
|
||||
(goops-error "no prefixes supplied"))))
|
||||
|
||||
(define (make-generic . name)
|
||||
(let ((name (and (pair? name) (car name))))
|
||||
(make <generic> #:name name)))
|
||||
(define* (make-generic #:optional name)
|
||||
(make <generic> #:name name))
|
||||
|
||||
(define (make-extended-generic gfs . name)
|
||||
(let* ((name (and (pair? name) (car name)))
|
||||
(gfs (if (pair? gfs) gfs (list gfs)))
|
||||
(define* (make-extended-generic gfs #:optional name)
|
||||
(let* ((gfs (if (list? gfs) gfs (list gfs)))
|
||||
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
|
||||
(let ((ans (if gws?
|
||||
(let* ((sname (and name (make-setter-name name)))
|
||||
|
|
@ -441,8 +439,7 @@
|
|||
(delq! eg (slot-ref gf 'extended-by))))
|
||||
gfs))
|
||||
|
||||
(define (ensure-generic old-definition . name)
|
||||
(let ((name (and (pair? name) (car name))))
|
||||
(define* (ensure-generic old-definition #:optional name)
|
||||
(cond ((is-a? old-definition <generic>) old-definition)
|
||||
((procedure-with-setter? old-definition)
|
||||
(make <generic-with-setter>
|
||||
|
|
@ -452,7 +449,7 @@
|
|||
((procedure? old-definition)
|
||||
(if (generic-capability? old-definition) old-definition
|
||||
(make <generic> #:name name #:default old-definition)))
|
||||
(else (make <generic> #:name name)))))
|
||||
(else (make <generic> #:name name))))
|
||||
|
||||
;; same semantics as <generic>
|
||||
(define-syntax define-accessor
|
||||
|
|
@ -466,15 +463,13 @@
|
|||
(define (make-setter-name name)
|
||||
(string->symbol (string-append "setter:" (symbol->string name))))
|
||||
|
||||
(define (make-accessor . name)
|
||||
(let ((name (and (pair? name) (car name))))
|
||||
(define* (make-accessor #:optional name)
|
||||
(make <accessor>
|
||||
#:name name
|
||||
#:setter (make <generic>
|
||||
#:name (and name (make-setter-name name))))))
|
||||
#:name (and name (make-setter-name name)))))
|
||||
|
||||
(define (ensure-accessor proc . name)
|
||||
(let ((name (and (pair? name) (car name))))
|
||||
(define* (ensure-accessor proc #:optional name)
|
||||
(cond ((and (is-a? proc <accessor>)
|
||||
(is-a? (setter proc) <generic>))
|
||||
proc)
|
||||
|
|
@ -493,7 +488,7 @@
|
|||
(ensure-generic proc name))
|
||||
name))
|
||||
(else
|
||||
(make-accessor name)))))
|
||||
(make-accessor name))))
|
||||
|
||||
(define (upgrade-accessor generic setter)
|
||||
(let ((methods (slot-ref generic 'methods))
|
||||
|
|
|
|||
|
|
@ -1,40 +0,0 @@
|
|||
;;; PROGRAM --- Does something
|
||||
|
||||
;; 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, 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 software; see the file COPYING.LESSER. If
|
||||
;; not, write to the Free Software Foundation, Inc., 51 Franklin
|
||||
;; Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Author: J.R.Hacker
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Usage: PROGRAM [ARGS]
|
||||
;;
|
||||
;; PROGRAM does something.
|
||||
;;
|
||||
;; TODO: Write it!
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (scripts PROGRAM)
|
||||
:export (PROGRAM))
|
||||
|
||||
(define (PROGRAM . args)
|
||||
#t)
|
||||
|
||||
(define main PROGRAM)
|
||||
|
||||
;;; PROGRAM ends here
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
;;; api-diff --- diff guile-api.alist files
|
||||
|
||||
;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2006, 2011 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
|
||||
|
|
@ -46,6 +46,9 @@
|
|||
:autoload (srfi srfi-13) (string-tokenize)
|
||||
:export (api-diff))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Show differences between two scan-api files.")
|
||||
|
||||
(define (read-alist-file file)
|
||||
(with-input-from-file file
|
||||
(lambda () (read))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; autofrisk --- Generate module checks for use with auto* tools
|
||||
|
||||
;; Copyright (C) 2002, 2006, 2009 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2006, 2009, 2011 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
|
||||
|
|
@ -62,6 +62,9 @@
|
|||
:use-module (scripts frisk)
|
||||
:export (autofrisk))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Generate snippets for use in configure.ac files.")
|
||||
|
||||
(define *recognized-keys* '(files-glob
|
||||
non-critical-external
|
||||
non-critical-internal
|
||||
|
|
|
|||
|
|
@ -37,6 +37,8 @@
|
|||
#:use-module (ice-9 format)
|
||||
#:export (compile))
|
||||
|
||||
(define %summary "Compile a file.")
|
||||
|
||||
|
||||
(define (fail . messages)
|
||||
(format (current-error-port) "error: ~{~a~}~%" messages)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Disassemble --- Disassemble .go files into something human-readable
|
||||
|
||||
;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc.
|
||||
;; Copyright 2005, 2008, 2009, 2011 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
|
||||
|
|
@ -32,6 +32,8 @@
|
|||
#:renamer (symbol-prefix-proc 'asm:))
|
||||
#:export (disassemble))
|
||||
|
||||
(define %summary "Disassemble a compiled .go file.")
|
||||
|
||||
(define (disassemble . files)
|
||||
(for-each (lambda (file)
|
||||
(asm:disassemble (load-objcode file)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; display-commentary --- As advertized
|
||||
|
||||
;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2006, 2011 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
|
||||
|
|
@ -33,6 +33,8 @@
|
|||
:use-module (ice-9 documentation)
|
||||
:export (display-commentary))
|
||||
|
||||
(define %summary "Display the Commentary section from a file or module.")
|
||||
|
||||
(define (display-commentary-one file)
|
||||
(format #t "~A commentary:\n~A" file (file-commentary file)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; doc-snarf --- Extract documentation from source files
|
||||
|
||||
;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2006, 2011 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
|
||||
|
|
@ -83,6 +83,8 @@ This procedure foos, or bars, depending on the argument @var{braz}.
|
|||
:use-module (ice-9 rdelim)
|
||||
:export (doc-snarf))
|
||||
|
||||
(define %summary "Snarf out documentation from a file.")
|
||||
|
||||
(define command-synopsis
|
||||
'((version (single-char #\v) (value #f))
|
||||
(help (single-char #\h) (value #f))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; frisk --- Grok the module interfaces of a body of files
|
||||
|
||||
;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2006, 2010, 2011 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
|
||||
|
|
@ -103,6 +103,9 @@
|
|||
mod-up-ls mod-down-ls mod-int?
|
||||
edge-type edge-up edge-down))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Show dependency information for a module.")
|
||||
|
||||
(define *default-module* '(guile-user))
|
||||
|
||||
(define (grok-proc default-module note-use!)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; generate-autoload --- Display define-module form with autoload info
|
||||
|
||||
;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2006, 2011 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
|
||||
|
|
@ -59,6 +59,9 @@
|
|||
(define-module (scripts generate-autoload)
|
||||
:export (generate-autoload))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Generate #:autoload clauses for a module.")
|
||||
|
||||
(define (autoload-info file)
|
||||
(let ((p (open-input-file file)))
|
||||
(let loop ((form (read p)) (module-name #f) (exports '()))
|
||||
|
|
|
|||
148
module/scripts/help.scm
Normal file
148
module/scripts/help.scm
Normal file
|
|
@ -0,0 +1,148 @@
|
|||
;;; Help --- Show help on guild commands
|
||||
|
||||
;;;; Copyright (C) 2009, 2010, 2011 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 3 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free
|
||||
;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;;;; Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Usage: help
|
||||
;;
|
||||
;; Show help for Guild scripts.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (scripts help)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 documentation)
|
||||
#:use-module ((srfi srfi-1) #:select (fold append-map))
|
||||
#:export (main))
|
||||
|
||||
(define %summary "Show a brief help message.")
|
||||
|
||||
|
||||
(define (directory-files dir)
|
||||
(if (and (file-exists? dir) (file-is-directory? dir))
|
||||
(let ((dir-stream (opendir dir)))
|
||||
(let loop ((new (readdir dir-stream))
|
||||
(acc '()))
|
||||
(if (eof-object? new)
|
||||
(begin
|
||||
(closedir dir-stream)
|
||||
acc)
|
||||
(loop (readdir dir-stream)
|
||||
(if (or (string=? "." new) ; ignore
|
||||
(string=? ".." new)) ; ignore
|
||||
acc
|
||||
(cons new acc))))))
|
||||
'()))
|
||||
|
||||
(define (strip-extensions path)
|
||||
(or-map (lambda (ext)
|
||||
(and
|
||||
(string-suffix? ext path)
|
||||
;; We really can't be adding e.g. ChangeLog-2008 to the set
|
||||
;; of runnable scripts, just because "" is a valid
|
||||
;; extension, by default. So hack around that here.
|
||||
(not (string-null? ext))
|
||||
(substring path 0
|
||||
(- (string-length path) (string-length ext)))))
|
||||
(append %load-compiled-extensions %load-extensions)))
|
||||
|
||||
(define (unique l)
|
||||
(cond ((null? l) l)
|
||||
((null? (cdr l)) l)
|
||||
((equal? (car l) (cadr l)) (unique (cdr l)))
|
||||
(else (cons (car l) (unique (cdr l))))))
|
||||
|
||||
(define (find-submodules head)
|
||||
(let ((shead (map symbol->string head)))
|
||||
(unique
|
||||
(sort
|
||||
(append-map (lambda (path)
|
||||
(fold (lambda (x rest)
|
||||
(let ((stripped (strip-extensions x)))
|
||||
(if stripped (cons stripped rest) rest)))
|
||||
'()
|
||||
(directory-files
|
||||
(fold (lambda (x y) (in-vicinity y x)) path shead))))
|
||||
%load-path)
|
||||
string<?))))
|
||||
|
||||
(define (list-commands all?)
|
||||
(display "\
|
||||
Usage: guild COMMAND [ARGS]
|
||||
Run command-line scripts provided by GNU Guile and related programs.
|
||||
|
||||
Commands:
|
||||
")
|
||||
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(let* ((modname `(scripts ,(string->symbol name)))
|
||||
(mod (resolve-module modname #:ensure #f))
|
||||
(summary (and mod (and=> (module-variable mod '%summary)
|
||||
variable-ref))))
|
||||
(if (and mod
|
||||
(or all?
|
||||
(let ((v (module-variable mod '%include-in-guild-list)))
|
||||
(if v (variable-ref v) #t))))
|
||||
(if summary
|
||||
(format #t " ~A ~23t~a\n" name summary)
|
||||
(format #t " ~A\n" name)))))
|
||||
(find-submodules '(scripts)))
|
||||
(format #t "
|
||||
For help on a specific command, try \"guild help COMMAND\".
|
||||
|
||||
Report guild bugs to ~a
|
||||
GNU Guile home page: <http://www.gnu.org/software/guile/>
|
||||
General help using GNU software: <http://www.gnu.org/gethelp/>
|
||||
For complete documentation, run: info guile 'Using Guile Tools'
|
||||
" %guile-bug-report-address))
|
||||
|
||||
(define (module-commentary mod)
|
||||
(file-commentary
|
||||
(%search-load-path (module-filename mod))))
|
||||
|
||||
(define (main . args)
|
||||
(cond
|
||||
((null? args)
|
||||
(list-commands #f))
|
||||
((or (equal? args '("--all")) (equal? args '("-a")))
|
||||
(list-commands #t))
|
||||
((not (string-prefix? "-" (car args)))
|
||||
;; help for particular command
|
||||
(let* ((name (car args))
|
||||
(mod (resolve-module `(scripts ,(string->symbol name))
|
||||
#:ensure #f)))
|
||||
(if mod
|
||||
(let ((commentary (module-commentary mod)))
|
||||
(if commentary
|
||||
(display commentary)
|
||||
(format #t "No documentation found for command \"~a\".\n"
|
||||
name)))
|
||||
(begin
|
||||
(format #t "No command named \"~a\".\n" name)
|
||||
(exit 1)))))
|
||||
(else
|
||||
(display "Usage: guild help
|
||||
guild help --all
|
||||
guild help COMMAND
|
||||
|
||||
Show a help on guild commands. With --all, show arcane incantations as
|
||||
well. With COMMAND, show more detailed help for a particular command.
|
||||
")
|
||||
(exit 1))))
|
||||
|
|
@ -105,6 +105,9 @@
|
|||
#:use-module (ice-9 format)
|
||||
#:export (lint))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Check for bugs and style errors in a Scheme file.")
|
||||
|
||||
(define (lint filename)
|
||||
(let ((module-name (scan-file-for-module-name filename))
|
||||
(free-vars (uniq (scan-file-for-free-variables filename))))
|
||||
|
|
|
|||
|
|
@ -26,9 +26,11 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (scripts list)
|
||||
#:use-module ((srfi srfi-1) #:select (fold append-map))
|
||||
#:export (list-scripts))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "An alias for \"help\".")
|
||||
|
||||
|
||||
(define (directory-files dir)
|
||||
(if (and (file-exists? dir) (file-is-directory? dir))
|
||||
|
|
@ -50,6 +52,10 @@
|
|||
(or-map (lambda (ext)
|
||||
(and
|
||||
(string-suffix? ext path)
|
||||
;; We really can't be adding e.g. ChangeLog-2008 to the set
|
||||
;; of runnable scripts, just because "" is a valid
|
||||
;; extension, by default. So hack around that here.
|
||||
(not (string-null? ext))
|
||||
(substring path 0
|
||||
(- (string-length path) (string-length ext)))))
|
||||
(append %load-compiled-extensions %load-extensions)))
|
||||
|
|
@ -80,4 +86,5 @@
|
|||
(format #t "~A\n" x))
|
||||
(find-submodules '(scripts))))
|
||||
|
||||
(define main list-scripts)
|
||||
(define (main . args)
|
||||
(apply (@@ (scripts help) main) args))
|
||||
|
|
|
|||
|
|
@ -41,6 +41,9 @@
|
|||
(define-module (scripts punify)
|
||||
:export (punify))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Strip comments and whitespace from a Scheme file.")
|
||||
|
||||
(define (write-punily form)
|
||||
(cond ((and (list? form) (not (null? form)))
|
||||
(let ((first (car form)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
|
||||
|
||||
;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2004, 2006, 2011 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
|
||||
|
|
@ -49,6 +49,9 @@
|
|||
:autoload (srfi srfi-13) (string-join)
|
||||
:export (read-rfc822 read-rfc822-silently))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Validate an RFC822-style file.")
|
||||
|
||||
(define from-line-rx (make-regexp "^From "))
|
||||
(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
|
||||
(define header-cont-rx (make-regexp "^[ \t]+"))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
|
||||
|
||||
;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2006, 2011 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
|
||||
|
|
@ -91,6 +91,9 @@
|
|||
quoted?
|
||||
clump))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Print a parsed representation of a Scheme file.")
|
||||
|
||||
;; Try to figure out what FORM is and its various attributes.
|
||||
;; Call proc NOTE! with key (a symbol) and value.
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; read-text-outline --- Read a text outline and display it as a sexp
|
||||
|
||||
;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2006, 2011 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
|
||||
|
|
@ -118,6 +118,9 @@
|
|||
:autoload (ice-9 rdelim) (read-line)
|
||||
:autoload (ice-9 getopt-long) (getopt-long))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Convert textual outlines to s-expressions.")
|
||||
|
||||
(define (?? symbol)
|
||||
(let ((name (symbol->string symbol)))
|
||||
(string=? "?" (substring name (1- (string-length name))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; scan-api --- Scan and group interpreter and libguile interface elements
|
||||
|
||||
;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2006, 2011 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
|
||||
|
|
@ -65,6 +65,9 @@
|
|||
:use-module (ice-9 regex)
|
||||
:export (scan-api))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Generate an API description for a Guile extension.")
|
||||
|
||||
(define put set-object-property!)
|
||||
(define get object-property)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; snarf-check-and-output-texi --- called by the doc snarfer.
|
||||
|
||||
;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2002, 2006, 2011 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
|
||||
|
|
@ -26,6 +26,9 @@
|
|||
:use-module (ice-9 match)
|
||||
:export (snarf-check-and-output-texi))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Transform snarfed .doc files into texinfo documentation.")
|
||||
|
||||
;;; why aren't these in some module?
|
||||
|
||||
(define-macro (when cond . body)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
|
||||
|
||||
;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2006, 2011 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
|
||||
|
|
@ -35,6 +35,9 @@
|
|||
:use-module (ice-9 rdelim)
|
||||
:export (snarf-guile-m4-docs))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "Snarf out texinfo documentation from .m4 files.")
|
||||
|
||||
(define (display-texi lines)
|
||||
(display "@deffn {Autoconf Macro}")
|
||||
(for-each (lambda (line)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; summarize-guile-TODO --- Display Guile TODO list in various ways
|
||||
|
||||
;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2002, 2006, 2010, 2011 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
|
||||
|
|
@ -73,6 +73,9 @@
|
|||
:autoload (ice-9 common-list) (remove-if-not)
|
||||
:export (summarize-guile-TODO))
|
||||
|
||||
(define %include-in-guild-list #f)
|
||||
(define %summary "A quaint relic of the past.")
|
||||
|
||||
(define put set-object-property!)
|
||||
(define get object-property)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; use2dot --- Display module dependencies as a DOT specification
|
||||
|
||||
;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2006, 2011 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
|
||||
|
|
@ -53,6 +53,8 @@
|
|||
:select (make-frisker edge-type edge-up edge-down))
|
||||
:export (use2dot))
|
||||
|
||||
(define %summary "Print a module's dependencies in graphviz format.")
|
||||
|
||||
(define *default-module* '(guile-user))
|
||||
|
||||
(define (q s) ; quote
|
||||
|
|
|
|||
|
|
@ -103,6 +103,16 @@
|
|||
;;;
|
||||
;;; See also boot-9.scm:load.
|
||||
(define (compiled-file-name file)
|
||||
;; FIXME: would probably be better just to append SHA1(canon-path)
|
||||
;; to the %compile-fallback-path, to avoid deep directory stats.
|
||||
(define (canonical->suffix canon)
|
||||
(cond
|
||||
((string-prefix? "/" canon) canon)
|
||||
((and (> (string-length canon) 2)
|
||||
(eqv? (string-ref canon 1) #\:))
|
||||
;; Paths like C:... transform to /C...
|
||||
(string-append "/" (substring canon 0 1) (substring canon 2)))
|
||||
(else canon)))
|
||||
(define (compiled-extension)
|
||||
(cond ((or (null? %load-compiled-extensions)
|
||||
(string-null? (car %load-compiled-extensions)))
|
||||
|
|
@ -113,9 +123,7 @@
|
|||
(and %compile-fallback-path
|
||||
(let ((f (string-append
|
||||
%compile-fallback-path
|
||||
;; no need for '/' separator here, canonicalize-path
|
||||
;; will give us an absolute path
|
||||
(canonicalize-path file)
|
||||
(canonical->suffix (canonicalize-path file))
|
||||
(compiled-extension))))
|
||||
(and (false-if-exception (ensure-writable-dir (dirname f)))
|
||||
f))))
|
||||
|
|
|
|||
|
|
@ -485,21 +485,19 @@ Disassemble a file."
|
|||
"time EXP
|
||||
Time execution."
|
||||
(let* ((gc-start (gc-run-time))
|
||||
(tms-start (times))
|
||||
(real-start (get-internal-real-time))
|
||||
(run-start (get-internal-run-time))
|
||||
(result (repl-eval repl (repl-parse repl form)))
|
||||
(tms-end (times))
|
||||
(run-end (get-internal-run-time))
|
||||
(real-end (get-internal-real-time))
|
||||
(gc-end (gc-run-time)))
|
||||
(define (get proc start end)
|
||||
(exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
|
||||
(define (diff start end)
|
||||
(/ (- end start) 1.0 internal-time-units-per-second))
|
||||
(repl-print repl result)
|
||||
(display "clock utime stime cutime cstime gctime\n")
|
||||
(format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
|
||||
(get tms:clock tms-start tms-end)
|
||||
(get tms:utime tms-start tms-end)
|
||||
(get tms:stime tms-start tms-end)
|
||||
(get tms:cutime tms-start tms-end)
|
||||
(get tms:cstime tms-start tms-end)
|
||||
(get identity gc-start gc-end))
|
||||
(format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n"
|
||||
(diff real-start real-end)
|
||||
(diff run-start run-end)
|
||||
(diff gc-start gc-end))
|
||||
result))
|
||||
|
||||
(define-meta-command (profile repl (form) . opts)
|
||||
|
|
|
|||
116
module/web/client.scm
Normal file
116
module/web/client.scm
Normal file
|
|
@ -0,0 +1,116 @@
|
|||
;;; Web client
|
||||
|
||||
;; Copyright (C) 2011 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 3 of the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This library is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; Lesser General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU Lesser General Public
|
||||
;; License along with this library; if not, write to the Free Software
|
||||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
;; 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; (web client) is a simple HTTP URL fetcher for Guile.
|
||||
;;;
|
||||
;;; In its current incarnation, (web client) is synchronous. If you
|
||||
;;; want to fetch a number of URLs at once, probably the best thing to
|
||||
;;; do is to write an event-driven URL fetcher, similar in structure to
|
||||
;;; the web server.
|
||||
;;;
|
||||
;;; Another option, good but not as performant, would be to use threads,
|
||||
;;; possibly via par-map or futures.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (web client)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (web request)
|
||||
#:use-module (web response)
|
||||
#:use-module (web uri)
|
||||
#:export (open-socket-for-uri
|
||||
http-get))
|
||||
|
||||
(define (open-socket-for-uri uri)
|
||||
(let* ((ai (car (getaddrinfo (uri-host uri)
|
||||
(cond
|
||||
((uri-port uri) => number->string)
|
||||
(else (symbol->string (uri-scheme uri)))))))
|
||||
(s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
|
||||
(addrinfo:protocol ai))))
|
||||
(set-port-encoding! s "ISO-8859-1")
|
||||
(connect s (addrinfo:addr ai))
|
||||
;; Buffer input and output on this port.
|
||||
(setvbuf s _IOFBF)
|
||||
;; Enlarge the receive buffer.
|
||||
(setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
|
||||
s))
|
||||
|
||||
(define (decode-string bv encoding)
|
||||
(if (string-ci=? encoding "utf-8")
|
||||
(utf8->string bv)
|
||||
(let ((p (open-bytevector-input-port bv)))
|
||||
(set-port-encoding! p encoding)
|
||||
(let ((res (read-delimited "" p)))
|
||||
(close-port p)
|
||||
res))))
|
||||
|
||||
(define (text-type? type)
|
||||
(let ((type (symbol->string type)))
|
||||
(or (string-prefix? "text/" type)
|
||||
(string-suffix? "/xml" type)
|
||||
(string-suffix? "+xml" type))))
|
||||
|
||||
;; Logically the inverse of (web server)'s `sanitize-response'.
|
||||
;;
|
||||
(define (decode-response-body response body)
|
||||
;; `body' is either #f or a bytevector.
|
||||
(cond
|
||||
((not body) body)
|
||||
((bytevector? body)
|
||||
(let ((rlen (response-content-length response))
|
||||
(blen (bytevector-length body)))
|
||||
(cond
|
||||
((and rlen (not (= rlen blen)))
|
||||
(error "bad content-length" rlen blen))
|
||||
((response-content-type response)
|
||||
=> (lambda (type)
|
||||
(cond
|
||||
((text-type? (car type))
|
||||
(decode-string body (or (assq-ref (cdr type) 'charset)
|
||||
"iso-8859-1")))
|
||||
(else body))))
|
||||
(else body))))
|
||||
(else
|
||||
(error "unexpected body type" body))))
|
||||
|
||||
(define* (http-get uri #:key (port (open-socket-for-uri uri))
|
||||
(version '(1 . 1)) (keep-alive? #f) (extra-headers '())
|
||||
(decode-body? #t))
|
||||
(let ((req (build-request uri #:version version
|
||||
#:headers (if keep-alive?
|
||||
extra-headers
|
||||
(cons '(connection close)
|
||||
extra-headers)))))
|
||||
(write-request req port)
|
||||
(force-output port)
|
||||
(if (not keep-alive?)
|
||||
(shutdown port 1))
|
||||
(let* ((res (read-response port))
|
||||
(body (read-response-body res)))
|
||||
(if (not keep-alive?)
|
||||
(close-port port))
|
||||
(values res
|
||||
(if decode-body?
|
||||
(decode-response-body res body)
|
||||
body)))))
|
||||
|
|
@ -151,6 +151,8 @@
|
|||
(validate-headers? #t))
|
||||
"Construct an HTTP request object. If @var{validate-headers?} is true,
|
||||
the headers are each run through their respective validators."
|
||||
(let ((needs-host? (and (equal? version '(1 . 1))
|
||||
(not (assq-ref headers 'host)))))
|
||||
(cond
|
||||
((not (and (pair? version)
|
||||
(non-negative-integer? (car version))
|
||||
|
|
@ -162,10 +164,18 @@ the headers are each run through their respective validators."
|
|||
(bad-request "Missing port for message ~a" method))
|
||||
((not (list? meta))
|
||||
(bad-request "Bad metadata alist" meta))
|
||||
((and needs-host? (not (uri-host uri)))
|
||||
(bad-request "HTTP/1.1 request without Host header and no host in URI: ~a"
|
||||
uri))
|
||||
(else
|
||||
(if validate-headers?
|
||||
(validate-headers headers))))
|
||||
(make-request method uri version headers meta port))
|
||||
(make-request method uri version
|
||||
(if needs-host?
|
||||
(acons 'host (cons (uri-host uri) (uri-port uri))
|
||||
headers)
|
||||
headers)
|
||||
meta port)))
|
||||
|
||||
(define* (read-request port #:optional (meta '()))
|
||||
"Read an HTTP request from @var{port}, optionally attaching the given
|
||||
|
|
|
|||
|
|
@ -290,6 +290,10 @@
|
|||
(import2 (make-module))
|
||||
(handler-invoked? #f)
|
||||
(handler (lambda (module name int1 val1 int2 val2 var val)
|
||||
;; We expect both VAR and VAL to be #f, as there
|
||||
;; is no previous binding for 'imported in M.
|
||||
(if var (error "unexpected var" var))
|
||||
(if val (error "unexpected val" val))
|
||||
(set! handler-invoked? #t)
|
||||
;; Keep the first binding.
|
||||
(or var (module-local-variable int1 name)))))
|
||||
|
|
|
|||
|
|
@ -428,6 +428,7 @@
|
|||
|
||||
(with-test-prefix "#{}#"
|
||||
(pass-if (equal? (read-string "#{}#") '#{}#))
|
||||
(pass-if (not (equal? (read-string "(a #{.}# b)") '(a . b))))
|
||||
(pass-if (equal? (read-string "#{a}#") 'a))
|
||||
(pass-if (equal? (read-string "#{a b}#") '#{a b}#))
|
||||
(pass-if-exception "#{" exception:eof-in-symbol
|
||||
|
|
|
|||
|
|
@ -436,7 +436,26 @@
|
|||
(make-c32vector 4 7)))
|
||||
|
||||
(pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
|
||||
(c32vector? #c32(+inf.0 -inf.0 +nan.0))))
|
||||
(c32vector? #c32(+inf.0 -inf.0 +nan.0)))
|
||||
|
||||
(pass-if "generalized-vector-ref"
|
||||
(let ((v (c32vector 1+1i)))
|
||||
(= (c32vector-ref v 0)
|
||||
(generalized-vector-ref v 0))))
|
||||
|
||||
(pass-if "generalized-vector-set!"
|
||||
(let ((x 1+1i)
|
||||
(v (c32vector 0)))
|
||||
(generalized-vector-set! v 0 x)
|
||||
(= x (generalized-vector-ref v 0))))
|
||||
|
||||
(pass-if-exception "generalized-vector-ref, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-ref (c32vector 1.0) 1))
|
||||
|
||||
(pass-if-exception "generalized-vector-set!, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-set! (c32vector 1.0) 1 2.0)))
|
||||
|
||||
(with-test-prefix "c64 vectors"
|
||||
|
||||
|
|
@ -476,4 +495,23 @@
|
|||
(make-c64vector 4 7)))
|
||||
|
||||
(pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
|
||||
(c64vector? #c64(+inf.0 -inf.0 +nan.0))))
|
||||
(c64vector? #c64(+inf.0 -inf.0 +nan.0)))
|
||||
|
||||
(pass-if "generalized-vector-ref"
|
||||
(let ((v (c64vector 1+1i)))
|
||||
(= (c64vector-ref v 0)
|
||||
(generalized-vector-ref v 0))))
|
||||
|
||||
(pass-if "generalized-vector-set!"
|
||||
(let ((x 1+1i)
|
||||
(v (c64vector 0)))
|
||||
(generalized-vector-set! v 0 x)
|
||||
(= x (generalized-vector-ref v 0))))
|
||||
|
||||
(pass-if-exception "generalized-vector-ref, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-ref (c64vector 1.0) 1))
|
||||
|
||||
(pass-if-exception "generalized-vector-set!, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-set! (c64vector 1.0) 1 2.0)))
|
||||
|
|
|
|||
|
|
@ -47,6 +47,10 @@ Accept-Language: en-gb, en;q=0.9\r
|
|||
(set! r (read-request (open-input-string example-1)))
|
||||
(request? r)))
|
||||
|
||||
(pass-if (equal?
|
||||
(request-host (build-request (string->uri "http://www.gnu.org/")))
|
||||
'("www.gnu.org" . #f)))
|
||||
|
||||
(pass-if (equal? (request-method r) 'GET))
|
||||
|
||||
(pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux")))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue