mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	configure.ac
	libguile/fluids.c
	libguile/gc.c
	libguile/gc.h
	libguile/objcodes.c
	libguile/procprop.c
	libguile/vm.c
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
This commit is contained in:
Andy Wingo 2011-12-01 23:31:50 +01:00
commit b2208d2e98
54 changed files with 10211 additions and 9681 deletions
Download patch file Download diff file Expand all files Collapse all files

23
README
View file

@ -239,25 +239,28 @@ switches specific to Guile you may find useful in some circumstances.
Cross building Guile =====================================================
As of guile-1.5.x, the build process uses compiled C files for
snarfing, and (indirectly, through libtool) for linking, and uses the
guile executable for generating documentation.
As of Guile 2.0.x, the build process produces a library, libguile-2.0,
along with Guile "object files" containing bytecode to be interpreted by
Guile's virtual machine. The bytecode format depends on the endianness
and word size of the host CPU.
When cross building guile, you first need to configure, build and
install guile for your build host.
Thus, when cross building Guile, you first need to configure, build and
install it for your build host.
Then, you may configure guile for cross building, eg:
Then, you may configure Guile for cross building:
./configure --host=i686-pc-cygwin --disable-shared
A C compiler for the build system is required. The default is
"PATH=/usr/bin:$PATH cc". If that doesn't suit it can be specified
with the CC_FOR_BUILD variable in the usual way, for instance
A C compiler for the build system is required. If that doesn't suit it
can be specified with the CC_FOR_BUILD variable in the usual way, for
instance:
./configure --host=m68k-unknown-linux-gnu CC_FOR_BUILD=/my/local/gcc
Guile for the build system can be specified similarly with the
GUILE_FOR_BUILD variable, it defaults to just "guile".
GUILE_FOR_BUILD variable, which defaults to whatever `guile' executable
is found in $PATH. It must have the exact same version has the Guile
that you intend to cross-build.
Using Guile Without Installing It =========================================

50
acinclude.m4
View file

@ -530,6 +530,56 @@ AC_DEFUN([GUILE_UNISTRING_ICONVEH_VALUES], [
GUILE_UNISTRING_CONSTANT([iconveh_escape_sequence])
])
dnl GUILE_CHECK_VERSION
dnl
dnl Ensure that $GUILE_FOR_BUILD has the same version as ourselves.
AC_DEFUN([GUILE_CHECK_VERSION], [
if ! "$GUILE_FOR_BUILD" --version > /dev/null 2>&1; then
AC_MSG_ERROR([failed to run `$GUILE_FOR_BUILD'])
fi
dnl Use MAJOR.MINOR.MICRO instead of (version) so that developers can
dnl freely shoot themselves in the foot by using, say, 2.0.3.80 and
dnl 2.0.3.42.
AC_CACHE_CHECK([the version of $GUILE_FOR_BUILD],
[ac_cv_guile_for_build_version],
[ac_cv_guile_for_build_version="`"$GUILE_FOR_BUILD" \
-c '(format #t "~a.~a.~a" (major-version) (minor-version) (micro-version))'`"
])
if test "$ac_cv_guile_for_build_version" != \
"$GUILE_MAJOR_VERSION.$GUILE_MINOR_VERSION.$GUILE_MICRO_VERSION"
then
AC_MSG_ERROR([building Guile $PACKAGE_VERSION but `$GUILE_FOR_BUILD' has version $ac_cv_guile_for_build_version"])
fi
])
dnl GUILE_CHECK_GUILE_FOR_BUILD
dnl
dnl When cross-compiling, ensure that $GUILE_FOR_BUILD is suitable.
AC_DEFUN([GUILE_CHECK_GUILE_FOR_BUILD], [
if test "$cross_compiling" = "yes"; then
if test "x$GUILE_FOR_BUILD" = "x"; then
AC_PATH_PROG([GUILE_FOR_BUILD], [guile], [not-found])
if test "$GUILE_FOR_BUILD" = "not-found"; then
AC_MSG_ERROR([a native Guile $PACKAGE_VERSION is required to cross-build Guile])
fi
fi
AC_MSG_CHECKING([guile for build])
AC_MSG_RESULT([$GUILE_FOR_BUILD])
dnl Since there is currently no distinction between the run-time
dnl search path, %load-path, and the compiler's search path,
dnl $GUILE_FOR_BUILD must be a native build of the very same version.
GUILE_CHECK_VERSION
else
GUILE_FOR_BUILD='this-value-will-never-be-used'
fi
AC_ARG_VAR([GUILE_FOR_BUILD], [guile for the build system])
AM_SUBST_NOTMAKE([GUILE_FOR_BUILD])
])
dnl Declare file $1 to be a script that needs configuring,
dnl and arrange to make it executable in the process.
AC_DEFUN([GUILE_CONFIG_SCRIPT],[AC_CONFIG_FILES([$1],[chmod +x $1])])

7
am/guilec
View file

@ -26,6 +26,9 @@ AM_V_GUILEC_0 = @echo " GUILEC" $@;
SUFFIXES = .scm .go
.scm.go:
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
guild compile $(GUILE_WARNINGS) -o "$@" "$<"
guild compile --target="$(host)" $(GUILE_WARNINGS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
-o "$@" "$<"

5
benchmark-suite/lib.scm
View file

@ -1,5 +1,5 @@
;;;; benchmark-suite/lib.scm --- generic support for benchmarking
;;;; 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
@ -348,8 +348,7 @@
(append (current-benchmark-prefix) (list name)))
;;; A fluid containing the current benchmark prefix, as a list.
(define prefix-fluid (make-fluid))
(fluid-set! prefix-fluid '())
(define prefix-fluid (make-fluid '()))
(define (current-benchmark-prefix)
(fluid-ref prefix-fluid))

17
configure.ac
View file

@ -1259,7 +1259,7 @@ save_LIBS="$LIBS"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link])
AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
@ -1511,20 +1511,7 @@ AC_SUBST(CCLD_FOR_BUILD)
HOST_CC="$CC_FOR_BUILD"
AC_SUBST(HOST_CC)
if test "$cross_compiling" = "yes"; then
AC_MSG_CHECKING(guile for build)
GUILE_FOR_BUILD="${GUILE_FOR_BUILD-guile}"
else
GUILE_FOR_BUILD='this-value-will-never-be-used'
fi
## AC_MSG_CHECKING("if we are cross compiling")
## AC_MSG_RESULT($cross_compiling)
if test "$cross_compiling" = "yes"; then
AC_MSG_RESULT($GUILE_FOR_BUILD)
fi
AC_ARG_VAR(GUILE_FOR_BUILD,[guile for build system])
AM_SUBST_NOTMAKE(GUILE_FOR_BUILD)
GUILE_CHECK_GUILE_FOR_BUILD
## If we're using GCC, ask for aggressive warnings.
GCC_CFLAGS=""

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

@ -4546,7 +4546,8 @@ Fill bytevector @var{bv} with @var{fill}, a byte.
@deffnx {C Function} scm_bytevector_copy_x (source, source_start, target, target_start, len)
Copy @var{len} bytes from @var{source} into @var{target}, starting
reading from @var{source-start} (a positive index within @var{source})
and start writing at @var{target-start}.
and start writing at @var{target-start}. It is permitted for the
@var{source} and @var{target} regions to overlap.
@end deffn
@deffn {Scheme Procedure} bytevector-copy bv

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

@ -640,6 +640,13 @@ Use @var{lang} as the source language of @var{file}. If this option is omitted,
Use @var{lang} as the target language of @var{file}. If this option is omitted,
@code{objcode} is assumed.
@item -T @var{target}
@itemx --target=@var{target}
Produce bytecode for @var{target} instead of @var{%host-type}
(@pxref{Build Config, %host-type}). Target must be a valid GNU triplet,
such as @code{armv5tel-unknown-linux-gnueabi} (@pxref{Specifying Target
Triplets,,, autoconf, GNU Autoconf Manual}).
@end table
Each @var{file} is assumed to be UTF-8-encoded, unless it contains a

8
doc/ref/intro.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -8,9 +8,9 @@
@chapter Introduction
Guile is an implementation of the Scheme programming language. Scheme
(@url{schemers.org}) is an elegant and conceptually simple dialect of
Lisp, originated by Guy Steele and Gerald Sussman, and since evolved
by the series of reports known as RnRS (the
(@url{http://schemers.org/}) is an elegant and conceptually simple
dialect of Lisp, originated by Guy Steele and Gerald Sussman, and since
evolved by the series of reports known as RnRS (the
@tex
Revised$^n$
@end tex

4
doc/ref/scheme-reading.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -10,7 +10,7 @@
@itemize @bullet
@item
The website @url{http://www.schemers.org} is a good starting point for
The website @url{http://www.schemers.org/} is a good starting point for
all things Scheme.
@item

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

@ -16,7 +16,7 @@ Guile has support for a number of SRFIs. This chapter gives an overview
over the available SRFIs and some usage hints. For complete
documentation, design rationales and further examples, we advise you to
get the relevant SRFI documents from the SRFI home page
@url{http://srfi.schemers.org}.
@url{http://srfi.schemers.org/}.
@menu
* About SRFI Usage:: What to know about Guile's SRFI support.

2
doc/ref/web.texi
View file

@ -847,7 +847,7 @@ indicating any etag, or a list of entity tags.
Indicates that a response should proceed if and only if the resource has
been modified since the given date.
@example
(parse-header if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT")
(parse-header 'if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT")
@result{} #<date ...>
@end example
@end deftypevr

6
libguile/bytevectors.c
View file

@ -596,9 +596,9 @@ SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
scm_out_of_range (FUNC_NAME, target_start);
memcpy (c_target + c_target_start,
c_source + c_source_start,
c_len);
memmove (c_target + c_target_start,
c_source + c_source_start,
c_len);
return SCM_UNSPECIFIED;
}

42
libguile/fluids.c
View file

@ -68,7 +68,7 @@ grow_dynamic_state (SCM state)
/* Assume the assignment below is atomic. */
len = allocated_fluids_len;
new_fluids = scm_c_make_vector (len, SCM_BOOL_F);
new_fluids = scm_c_make_vector (len, SCM_UNDEFINED);
for (i = 0; i < old_len; i++)
SCM_SIMPLE_VECTOR_SET (new_fluids, i,
@ -103,14 +103,14 @@ scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
/* Return a new fluid. */
static SCM
new_fluid ()
new_fluid (SCM init)
{
SCM fluid;
size_t trial, n;
/* Fluids are pointerless cells: the first word is the type tag; the second
word is the fluid number. */
fluid = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_cell), "fluid"));
/* Fluids hold the type tag and the fluid number in the first word,
and the default value in the second word. */
fluid = scm_cell (scm_tc7_fluid, SCM_UNPACK (init));
SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid);
scm_dynwind_begin (0);
@ -157,7 +157,7 @@ new_fluid ()
}
allocated_fluids[n] = SCM_UNPACK_POINTER (fluid);
SCM_SET_CELL_WORD_1 (fluid, (scm_t_bits) n);
SCM_SET_CELL_WORD_0 (fluid, (scm_tc7_fluid | (n << 8)));
GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n],
SCM_HEAP_OBJECT_BASE (fluid));
@ -166,13 +166,19 @@ new_fluid ()
/* Now null out values. We could (and probably should) do this when
the fluid is collected instead of now. */
scm_i_reset_fluid (n, SCM_BOOL_F);
scm_i_reset_fluid (n);
return fluid;
}
SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
(),
SCM
scm_make_fluid (void)
{
return new_fluid (SCM_BOOL_F);
}
SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0,
(SCM dflt),
"Return a newly created fluid.\n"
"Fluids are objects that can hold one\n"
"value per dynamic state. That is, modifications to this value are\n"
@ -180,9 +186,9 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
"the modifying code. When a new dynamic state is constructed, it\n"
"inherits the values from its parent. Because each thread normally executes\n"
"with its own dynamic state, you can use fluids for thread local storage.")
#define FUNC_NAME s_scm_make_fluid
#define FUNC_NAME s_scm_make_fluid_with_default
{
return new_fluid ();
return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt);
}
#undef FUNC_NAME
@ -191,9 +197,7 @@ SCM_DEFINE (scm_make_unbound_fluid, "make-unbound-fluid", 0, 0, 0,
"Make a fluid that is initially unbound.")
#define FUNC_NAME s_scm_make_unbound_fluid
{
SCM f = new_fluid ();
scm_fluid_set_x (f, SCM_UNDEFINED);
return f;
return new_fluid (SCM_UNDEFINED);
}
#undef FUNC_NAME
@ -217,6 +221,7 @@ scm_is_fluid (SCM obj)
static SCM
fluid_ref (SCM fluid)
{
SCM ret;
SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
@ -227,7 +232,11 @@ fluid_ref (SCM fluid)
fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
}
return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
ret = SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
if (SCM_UNBNDP (ret))
return SCM_I_FLUID_DEFAULT (fluid);
else
return ret;
}
SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
@ -274,6 +283,9 @@ SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0,
"Unset the value associated with @var{fluid}.")
#define FUNC_NAME s_scm_fluid_unset_x
{
/* FIXME: really unset the default value, too? The current test
suite demands it, but I would prefer not to. */
SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED);
return scm_fluid_set_x (fluid, SCM_UNDEFINED);
}
#undef FUNC_NAME

4
libguile/fluids.h
View file

@ -56,10 +56,12 @@
#define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid))
#ifdef BUILDING_LIBGUILE
#define SCM_I_FLUID_NUM(x) ((size_t)SCM_CELL_WORD_1(x))
#define SCM_I_FLUID_NUM(x) ((size_t)(SCM_CELL_WORD_0 (x) >> 8))
#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x))
#endif
SCM_API SCM scm_make_fluid (void);
SCM_API SCM scm_make_fluid_with_default (SCM dflt);
SCM_API SCM scm_make_unbound_fluid (void);
SCM_API int scm_is_fluid (SCM obj);
SCM_API SCM scm_fluid_p (SCM fl);

16
libguile/foreign.c
View file

@ -1124,7 +1124,7 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
"type should match @var{return-type} and @var{arg-types}.\n")
#define FUNC_NAME s_scm_procedure_to_pointer
{
SCM pointer;
SCM cif_pointer, pointer;
ffi_cif *cif;
ffi_status err;
void *closure, *executable;
@ -1141,8 +1141,17 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL);
}
/* CIF points to GC-managed memory and it should remain as long as
POINTER (see below) is live. Wrap it in a Scheme pointer to then
hold a weak reference on it. */
cif_pointer = scm_from_pointer (cif, NULL);
if (closure == executable)
pointer = scm_from_pointer (executable, ffi_closure_free);
{
pointer = scm_from_pointer (executable, ffi_closure_free);
register_weak_reference (pointer,
scm_list_2 (proc, cif_pointer));
}
else
{
/* CLOSURE needs to be freed eventually. However, since
@ -1155,7 +1164,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
pointer = scm_from_pointer (executable, NULL);
friend = scm_from_pointer (closure, ffi_closure_free);
register_weak_reference (pointer, friend);
register_weak_reference (pointer,
scm_list_3 (proc, cif_pointer, friend));
}
return pointer;

4
libguile/gc-malloc.c
View file

@ -88,12 +88,14 @@ scm_realloc (void *mem, size_t size)
{
void *ptr;
scm_gc_register_allocation (size);
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)
return ptr;
/* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */
GC_gcollect ();
GC_gcollect_and_unmap ();
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)

220
libguile/gc.c
View file

@ -27,6 +27,7 @@
#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <math.h>
#ifdef __ia64__
#include <ucontext.h>
@ -187,6 +188,32 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
/* Compatibility. */
#ifndef HAVE_GC_GET_HEAP_USAGE_SAFE
static void
GC_get_heap_usage_safe (GC_word *pheap_size, GC_word *pfree_bytes,
GC_word *punmapped_bytes, GC_word *pbytes_since_gc,
GC_word *ptotal_bytes)
{
*pheap_size = GC_get_heap_size ();
*pfree_bytes = GC_get_free_bytes ();
*punmapped_bytes = GC_get_unmapped_bytes ();
*pbytes_since_gc = GC_get_bytes_since_gc ();
*ptotal_bytes = GC_get_total_bytes ();
}
#endif
#ifndef HAVE_GC_GET_FREE_SPACE_DIVISOR
static GC_word
GC_get_free_space_divisor (void)
{
return GC_free_space_divisor;
}
#endif
/* Hooks. */
scm_t_c_hook scm_before_gc_c_hook;
@ -209,6 +236,9 @@ unsigned long scm_gc_ports_collected = 0;
static long gc_time_taken = 0;
static long gc_start_time = 0;
static unsigned long free_space_divisor;
static unsigned long minimum_free_space_divisor;
static double target_free_space_divisor;
static unsigned long protected_obj_count = 0;
@ -270,14 +300,12 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
#define FUNC_NAME s_scm_gc_stats
{
SCM answer;
size_t heap_size, free_bytes, bytes_since_gc, total_bytes;
GC_word heap_size, free_bytes, unmapped_bytes, bytes_since_gc, total_bytes;
size_t gc_times;
heap_size = GC_get_heap_size ();
free_bytes = GC_get_free_bytes ();
bytes_since_gc = GC_get_bytes_since_gc ();
total_bytes = GC_get_total_bytes ();
gc_times = GC_gc_no;
GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
&bytes_since_gc, &total_bytes);
gc_times = GC_gc_no;
answer =
scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
@ -579,7 +607,10 @@ void
scm_storage_prehistory ()
{
GC_all_interior_pointers = 0;
GC_set_free_space_divisor (scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3));
free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
minimum_free_space_divisor = free_space_divisor;
target_free_space_divisor = free_space_divisor;
GC_set_free_space_divisor (free_space_divisor);
GC_INIT ();
@ -723,7 +754,8 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED,
void *data SCM_UNUSED)
{
if (gc_start_time)
{ long now = scm_c_get_internal_run_time ();
{
long now = scm_c_get_internal_run_time ();
gc_time_taken += now - gc_start_time;
gc_start_time = 0;
}
@ -731,6 +763,168 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED,
return NULL;
}
/* Return some idea of the memory footprint of a process, in bytes.
Currently only works on Linux systems. */
static size_t
get_image_size (void)
{
unsigned long size, resident, share;
size_t ret = 0;
FILE *fp = fopen ("/proc/self/statm", "r");
if (fp && fscanf (fp, "%lu %lu %lu", &size, &resident, &share) == 3)
ret = resident * 4096;
if (fp)
fclose (fp);
return ret;
}
/* These are discussed later. */
static size_t bytes_until_gc;
static scm_i_pthread_mutex_t bytes_until_gc_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Make GC run more frequently when the process image size is growing,
measured against the number of bytes allocated through the GC.
If Guile is allocating at a GC-managed heap size H, libgc will tend
to limit the process image size to H*N. But if at the same time the
user program is mallocating at a rate M bytes per GC-allocated byte,
then the process stabilizes at H*N*M -- assuming that collecting data
will result in malloc'd data being freed. It doesn't take a very
large M for this to be a bad situation. To limit the image size,
Guile should GC more often -- the bigger the M, the more often.
Numeric functions that produce bigger and bigger integers are
pessimal, because M is an increasing function of time. Here is an
example of such a function:
(define (factorial n)
(define (fac n acc)
(if (<= n 1)
acc
(fac (1- n) (* n acc))))
(fac n 1))
It is possible for a process to grow for reasons that will not be
solved by faster GC. In that case M will be estimated as
artificially high for a while, and so GC will happen more often on
the Guile side. But when it stabilizes, Guile can ease back the GC
frequency.
The key is to measure process image growth, not mallocation rate.
For maximum effectiveness, Guile reacts quickly to process growth,
and exponentially backs down when the process stops growing.
See http://thread.gmane.org/gmane.lisp.guile.devel/12552/focus=12936
for further discussion.
*/
static void *
adjust_gc_frequency (void * hook_data SCM_UNUSED,
void *fn_data SCM_UNUSED,
void *data SCM_UNUSED)
{
static size_t prev_image_size = 0;
static size_t prev_bytes_alloced = 0;
size_t image_size;
size_t bytes_alloced;
scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
bytes_until_gc = GC_get_heap_size ();
scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
image_size = get_image_size ();
bytes_alloced = GC_get_total_bytes ();
#define HEURISTICS_DEBUG 0
#if HEURISTICS_DEBUG
fprintf (stderr, "prev image / alloced: %lu / %lu\n", prev_image_size, prev_bytes_alloced);
fprintf (stderr, " image / alloced: %lu / %lu\n", image_size, bytes_alloced);
fprintf (stderr, "divisor %lu / %f\n", free_space_divisor, target_free_space_divisor);
#endif
if (prev_image_size && bytes_alloced != prev_bytes_alloced)
{
double growth_rate, new_target_free_space_divisor;
double decay_factor = 0.5;
double hysteresis = 0.1;
growth_rate = ((double) image_size - prev_image_size)
/ ((double)bytes_alloced - prev_bytes_alloced);
#if HEURISTICS_DEBUG
fprintf (stderr, "growth rate %f\n", growth_rate);
#endif
new_target_free_space_divisor = minimum_free_space_divisor;
if (growth_rate > 0)
new_target_free_space_divisor *= 1.0 + growth_rate;
#if HEURISTICS_DEBUG
fprintf (stderr, "new divisor %f\n", new_target_free_space_divisor);
#endif
if (new_target_free_space_divisor < target_free_space_divisor)
/* Decay down. */
target_free_space_divisor =
(decay_factor * target_free_space_divisor
+ (1.0 - decay_factor) * new_target_free_space_divisor);
else
/* Jump up. */
target_free_space_divisor = new_target_free_space_divisor;
#if HEURISTICS_DEBUG
fprintf (stderr, "new target divisor %f\n", target_free_space_divisor);
#endif
if (free_space_divisor + 0.5 + hysteresis < target_free_space_divisor
|| free_space_divisor - 0.5 - hysteresis > target_free_space_divisor)
{
free_space_divisor = lround (target_free_space_divisor);
#if HEURISTICS_DEBUG
fprintf (stderr, "new divisor %lu\n", free_space_divisor);
#endif
GC_set_free_space_divisor (free_space_divisor);
}
}
prev_image_size = image_size;
prev_bytes_alloced = bytes_alloced;
return NULL;
}
/* The adjust_gc_frequency routine handles transients in the process
image size. It can't handle instense non-GC-managed steady-state
allocation though, as it decays the FSD at steady-state down to its
minimum value.
The only real way to handle continuous, high non-GC allocation is to
let the GC know about it. This routine can handle non-GC allocation
rates that are similar in size to the GC-managed heap size.
*/
void
scm_gc_register_allocation (size_t size)
{
scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
if (bytes_until_gc - size > bytes_until_gc)
{
bytes_until_gc = GC_get_heap_size ();
scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
GC_gcollect ();
}
else
{
bytes_until_gc -= size;
scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
}
}
@ -833,6 +1027,16 @@ scm_init_gc ()
scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
#if HAVE_GC_GET_HEAP_USAGE_SAFE
/* GC_get_heap_usage does not take a lock, and so can run in the GC
start hook. */
scm_c_hook_add (&scm_before_gc_c_hook, adjust_gc_frequency, NULL, 0);
#else
/* GC_get_heap_usage might take a lock (and did from 7.2alpha1 to
7.2alpha7), so call it in the after_gc_hook. */
scm_c_hook_add (&scm_after_gc_c_hook, adjust_gc_frequency, NULL, 0);
#endif
#ifdef HAVE_GC_SET_START_CALLBACK
GC_set_start_callback (run_before_gc_c_hook);
#endif

2
libguile/gc.h
View file

@ -157,6 +157,8 @@ SCM_INTERNAL void scm_i_gc (const char *what);
SCM_API void scm_gc_mark (SCM p);
SCM_API void scm_gc_sweep (void);
SCM_API void scm_gc_register_allocation (size_t size);
SCM_API void *scm_malloc (size_t size) SCM_MALLOC;
SCM_API void *scm_calloc (size_t size) SCM_MALLOC;
SCM_API void *scm_realloc (void *mem, size_t size);

3
libguile/load.c
View file

@ -1043,8 +1043,7 @@ scm_init_load ()
scm_loc_fresh_auto_compile
= SCM_VARIABLE_LOC (scm_c_define ("%fresh-auto-compile", SCM_BOOL_F));
the_reader = scm_make_fluid ();
scm_fluid_set_x (the_reader, SCM_BOOL_F);
the_reader = scm_make_fluid_with_default (SCM_BOOL_F);
scm_c_define("current-reader", the_reader);
scm_c_define ("load-compiled",

2
libguile/memoize.c
View file

@ -292,7 +292,7 @@ memoize (SCM exp, SCM env)
int nreq, nopt, ntotal;
req = REF (exp, LAMBDA_CASE, REQ);
rest = REF (exp, LAMBDA_CASE, REST);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
opt = REF (exp, LAMBDA_CASE, OPT);
kw = REF (exp, LAMBDA_CASE, KW);
inits = REF (exp, LAMBDA_CASE, INITS);

130
libguile/objcodes.c
View file

@ -32,6 +32,7 @@
#include <sys/types.h>
#include <assert.h>
#include <alignof.h>
#include <byteswap.h>
#include <full-read.h>
@ -45,11 +46,55 @@
The length of the header must be a multiple of 8 bytes. */
verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
/* Endianness and word size of the compilation target. */
static SCM target_endianness_var = SCM_BOOL_F;
static SCM target_word_size_var = SCM_BOOL_F;
/*
* Objcode type
*/
/* Endianness of the build machine. */
#ifdef WORDS_BIGENDIAN
# define NATIVE_ENDIANNESS 'B'
#else
# define NATIVE_ENDIANNESS 'L'
#endif
/* Return the endianness of the compilation target. */
static char
target_endianness (void)
{
if (scm_is_true (target_endianness_var))
return scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
scm_endianness_big) ? 'B' : 'L';
else
return NATIVE_ENDIANNESS;
}
/* Return the word size in bytes of the compilation target. */
static size_t
target_word_size (void)
{
if (scm_is_true (target_word_size_var))
return scm_to_size_t (scm_call_0
(scm_variable_ref (target_word_size_var)));
else
return sizeof (void *);
}
/* Convert X, which is in byte order ENDIANNESS, to its native
representation. */
static inline uint32_t
to_native_order (uint32_t x, char endianness)
{
if (endianness == NATIVE_ENDIANNESS)
return x;
else
return bswap_32 (x);
}
static void
verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
#define FUNC_NAME "make_objcode_from_file"
@ -183,7 +228,7 @@ make_objcode_from_file (int fd)
verify_cookie (cookie, &st, -1, NULL);
return scm_bytecode_to_objcode (bv);
return scm_bytecode_to_native_objcode (bv);
}
#endif
}
@ -254,12 +299,12 @@ SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
(SCM bytecode),
"")
#define FUNC_NAME s_scm_bytecode_to_objcode
/* Turn BYTECODE into objcode encoded for ENDIANNESS and WORD_SIZE. */
static SCM
bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
#define FUNC_NAME "bytecode->objcode"
{
size_t size;
size_t size, len, metalen;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
@ -268,14 +313,17 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
size = SCM_BYTEVECTOR_LENGTH (bytecode);
c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
data = (struct scm_objcode*)c_bytecode;
if (data->len + data->metalen != (size - sizeof (*data)))
len = to_native_order (data->len, endianness);
metalen = to_native_order (data->metalen, endianness);
if (len + metalen != (size - sizeof (*data)))
scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
scm_list_2 (scm_from_size_t (size),
scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
scm_from_uint32 (sizeof (*data) + len + metalen)));
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */
@ -284,6 +332,27 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
(SCM bytecode),
"")
#define FUNC_NAME s_scm_bytecode_to_objcode
{
/* Assume we're called from Scheme, which known that to do with
`target-type'. */
return bytecode_to_objcode (bytecode, target_endianness (),
target_word_size ());
}
#undef FUNC_NAME
/* Like `bytecode->objcode', but ignore the `target-type' fluid. This
is useful for native compilation that happens lazily---e.g., direct
calls to this function from libguile itself. */
SCM
scm_bytecode_to_native_objcode (SCM bytecode)
{
return bytecode_to_objcode (bytecode, NATIVE_ENDIANNESS, sizeof (void *));
}
SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
(SCM file),
"")
@ -324,41 +393,37 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
"")
#define FUNC_NAME s_scm_write_objcode
{
static SCM target_endianness_var = SCM_BOOL_F;
static SCM target_word_size_var = SCM_BOOL_F;
char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
char endianness;
char word_size;
char endianness, word_size;
size_t total_size;
SCM_VALIDATE_OBJCODE (1, objcode);
SCM_VALIDATE_OUTPUT_PORT (2, port);
if (scm_is_false (target_endianness_var))
target_endianness_var =
scm_c_public_variable ("system base target", "target-endianness");
if (scm_is_false (target_word_size_var))
target_word_size_var =
scm_c_public_variable ("system base target", "target-word-size");
endianness =
scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
scm_endianness_big) ? 'B' : 'L';
switch (scm_to_int (scm_call_0 (scm_variable_ref (target_word_size_var))))
endianness = target_endianness ();
switch (target_word_size ())
{
case 4: word_size = '4'; break;
case 8: word_size = '8'; break;
default: abort ();
case 4:
word_size = '4';
break;
case 8:
word_size = '8';
break;
default:
abort ();
}
memcpy (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
cookie[SCM_OBJCODE_WORD_SIZE_OFFSET] = word_size;
total_size =
to_native_order (SCM_OBJCODE_LEN (objcode), target_endianness ())
+ to_native_order (SCM_OBJCODE_META_LEN (objcode), target_endianness ());
scm_c_write_unlocked (port, cookie, strlen (SCM_OBJCODE_COOKIE));
scm_c_write_unlocked (port, SCM_OBJCODE_DATA (objcode),
sizeof (struct scm_objcode)
+ SCM_OBJCODE_TOTAL_LEN (objcode));
+ total_size);
return SCM_UNSPECIFIED;
}
@ -398,6 +463,11 @@ scm_init_objcodes (void)
scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
target_endianness_var = scm_c_public_variable ("system base target",
"target-endianness");
target_word_size_var = scm_c_public_variable ("system base target",
"target-word-size");
}
/*

3
libguile/objcodes.h
View file

@ -60,11 +60,12 @@ struct scm_objcode
#define SCM_OBJCODE_NATIVE_CODE(x) (SCM_CELL_WORD_3 (x))
#define SCM_SET_OBJCODE_NATIVE_CODE(x, code) (SCM_SET_CELL_WORD_3 (x, code))
SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
SCM_API SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
SCM_API SCM scm_load_objcode (SCM file);
SCM_API SCM scm_objcode_p (SCM obj);
SCM_API SCM scm_objcode_meta (SCM objcode);
SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
SCM_INTERNAL SCM scm_bytecode_to_native_objcode (SCM bytecode);
SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);

10
libguile/ports.c
View file

@ -2762,13 +2762,13 @@ scm_init_ports ()
#include "libguile/ports.x"
/* Use Latin-1 as the default port encoding. */
SCM_VARIABLE_SET (default_port_encoding_var, scm_make_fluid ());
scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
SCM_VARIABLE_SET (default_port_encoding_var,
scm_make_fluid_with_default (SCM_BOOL_F));
scm_port_encoding_init = 1;
SCM_VARIABLE_SET (scm_conversion_strategy, scm_make_fluid ());
scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy),
scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK));
SCM_VARIABLE_SET (scm_conversion_strategy,
scm_make_fluid_with_default
(scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK)));
scm_conversion_strategy_init = 1;
}

33
libguile/procprop.c
View file

@ -43,9 +43,23 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
static SCM overrides;
static SCM arity_overrides;
int
scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
SCM o;
o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F);
if (scm_is_true (o))
{
*req = scm_to_int (scm_car (o));
*opt = scm_to_int (scm_cadr (o));
*rest = scm_is_true (scm_caddr (o));
return 1;
}
while (!SCM_PROGRAM_P (proc))
{
if (SCM_STRUCTP (proc))
@ -63,9 +77,27 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
else
return 0;
}
return scm_i_program_arity (proc, req, opt, rest);
}
SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
"")
#define FUNC_NAME s_scm_set_procedure_minimum_arity_x
{
int t SCM_UNUSED;
SCM_VALIDATE_PROC (1, proc);
SCM_VALIDATE_INT_COPY (2, req, t);
SCM_VALIDATE_INT_COPY (3, opt, t);
SCM_VALIDATE_BOOL (4, rest);
scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
return SCM_UNDEFINED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
(SCM proc),
"Return the \"minimum arity\" of a procedure.\n\n"
@ -171,6 +203,7 @@ void
scm_init_procprop ()
{
overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
#include "libguile/procprop.x"
}

2
libguile/procprop.h
View file

@ -33,6 +33,8 @@ SCM_API SCM scm_sym_system_procedure;
SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest);
SCM_API SCM scm_set_procedure_minimum_arity_x (SCM proc, SCM req, SCM opt,
SCM rest);
SCM_API SCM scm_procedure_minimum_arity (SCM proc);
SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);

3
libguile/read.c
View file

@ -1740,8 +1740,7 @@ scm_init_read ()
{
SCM read_hash_procs;
read_hash_procs = scm_make_fluid ();
scm_fluid_set_x (read_hash_procs, SCM_EOL);
read_hash_procs = scm_make_fluid_with_default (SCM_EOL);
scm_i_read_hash_procedures =
SCM_VARIABLE_LOC (scm_c_define ("%read-hash-procedures", read_hash_procs));

5
libguile/threads.c
View file

@ -477,7 +477,7 @@ static SCM scm_i_default_dynamic_state;
/* Run when a fluid is collected. */
void
scm_i_reset_fluid (size_t n, SCM val)
scm_i_reset_fluid (size_t n)
{
scm_i_thread *t;
@ -488,7 +488,7 @@ scm_i_reset_fluid (size_t n, SCM val)
SCM v = SCM_I_DYNAMIC_STATE_FLUIDS (t->dynamic_state);
if (n < SCM_SIMPLE_VECTOR_LENGTH (v))
SCM_SIMPLE_VECTOR_SET (v, n, val);
SCM_SIMPLE_VECTOR_SET (v, n, SCM_UNDEFINED);
}
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
}
@ -1001,6 +1001,7 @@ SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0,
SCM_ASSERT (SCM_UNBNDP (handler) || scm_is_true (scm_procedure_p (handler)),
handler, SCM_ARG2, FUNC_NAME);
GC_collect_a_little ();
data.parent = scm_current_dynamic_state ();
data.thunk = thunk;
data.handler = handler;

2
libguile/threads.h
View file

@ -136,7 +136,7 @@ SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data,
SCM_API void *scm_without_guile (void *(*func)(void *), void *data);
SCM_API void *scm_with_guile (void *(*func)(void *), void *data);
SCM_INTERNAL void scm_i_reset_fluid (size_t, SCM);
SCM_INTERNAL void scm_i_reset_fluid (size_t);
SCM_INTERNAL void scm_threads_prehistory (void *);
SCM_INTERNAL void scm_init_threads (void);
SCM_INTERNAL void scm_init_thread_procs (void);

2
libguile/vm-i-system.c
View file

@ -1660,6 +1660,8 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
else
{
SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
if (scm_is_eq (val, SCM_UNDEFINED))
val = SCM_I_FLUID_DEFAULT (*sp);
if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
{
finish_args = *sp;

2
libguile/vm.c
View file

@ -393,7 +393,7 @@ really_make_boot_program (long nargs)
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
sizeof (struct scm_objcode) + sizeof (text),
SCM_BOOL_F);
ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);

114
meta/uninstalled-env.in
View file

@ -46,62 +46,72 @@ top_builddir="@top_builddir_absolute@"
exit 1
}
if [ x"$GUILE_LOAD_PATH" = x ]
# When cross-compiling, let $GUILE_FOR_BUILD use its own .go files since
# the ones that are being built may be incompatible ($GUILE_FOR_BUILD is
# typically used to run `guild compile --target=$host'.) Likewise,
# $GUILE_FOR_BUILD must use its own source files when booting; for
# instance, $srcdir/module/ice-9/boot-9.scm must not be in its search
# path, because it would then end up using its C evaluator to run the
# compiler.
if test "@cross_compiling@" = "no"
then
GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline:${top_srcdir}"
if test "${top_srcdir}" != "${top_builddir}"; then
GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
if [ x"$GUILE_LOAD_PATH" = x ]
then
GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline:${top_srcdir}"
if test "${top_srcdir}" != "${top_builddir}"; then
GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
fi
else
for d in "/module" "/guile-readline" ""
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
case x"$GUILE_LOAD_PATH" in
x*${top_srcdir}${d}:*) ;;
x*${top_srcdir}${d}) ;;
*) GUILE_LOAD_PATH="${top_srcdir}${d}:$GUILE_LOAD_PATH" ;;
esac
case x"$GUILE_LOAD_PATH" in
x*${top_builddir}${d}:*) ;;
x*${top_builddir}${d}) ;;
*) GUILE_LOAD_PATH="${top_builddir}${d}:$GUILE_LOAD_PATH" ;;
esac
done
fi
else
for d in "/module" "/guile-readline" ""
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
case x"$GUILE_LOAD_PATH" in
x*${top_srcdir}${d}:*) ;;
x*${top_srcdir}${d}) ;;
*) GUILE_LOAD_PATH="${top_srcdir}${d}:$GUILE_LOAD_PATH" ;;
esac
case x"$GUILE_LOAD_PATH" in
x*${top_builddir}${d}:*) ;;
x*${top_builddir}${d}) ;;
*) GUILE_LOAD_PATH="${top_builddir}${d}:$GUILE_LOAD_PATH" ;;
esac
done
fi
export GUILE_LOAD_PATH
export GUILE_LOAD_PATH
if [ x"$GUILE_LOAD_COMPILED_PATH" = x ]
then
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
else
for d in "/module" "/guile-readline" ""
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
case x"$GUILE_LOAD_COMPILED_PATH" in
x*${top_builddir}${d}:*) ;;
x*${top_builddir}${d}) ;;
*) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}:$GUILE_LOAD_COMPILED_PATH" ;;
esac
done
fi
export GUILE_LOAD_COMPILED_PATH
if test "x$GUILE_LOAD_COMPILED_PATH" = "x"
then
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
else
for d in "/module" "/guile-readline" ""
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
case x"$GUILE_LOAD_COMPILED_PATH" in
x*${top_builddir}${d}:*) ;;
x*${top_builddir}${d}) ;;
*) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}:$GUILE_LOAD_COMPILED_PATH" ;;
esac
done
fi
export GUILE_LOAD_COMPILED_PATH
# Don't look in installed dirs for guile modules
if ( env | grep -v '^GUILE_SYSTEM_PATH=' > /dev/null ); then
GUILE_SYSTEM_PATH=
export GUILE_SYSTEM_PATH
fi
# Don't look in installed dirs for compiled guile modules
if ( env | grep -v '^GUILE_SYSTEM_COMPILED_PATH=' > /dev/null ); then
GUILE_SYSTEM_COMPILED_PATH=
export GUILE_SYSTEM_COMPILED_PATH
fi
# Don't look in installed dirs for dlopen-able modules
if ( env | grep -v '^GUILE_SYSTEM_EXTENSIONS_PATH=' > /dev/null ); then
GUILE_SYSTEM_EXTENSIONS_PATH=
export GUILE_SYSTEM_EXTENSIONS_PATH
# Don't look in installed dirs for guile modules
if ( env | grep -v '^GUILE_SYSTEM_PATH=' > /dev/null ); then
GUILE_SYSTEM_PATH=
export GUILE_SYSTEM_PATH
fi
# Don't look in installed dirs for compiled guile modules
if ( env | grep -v '^GUILE_SYSTEM_COMPILED_PATH=' > /dev/null ); then
GUILE_SYSTEM_COMPILED_PATH=
export GUILE_SYSTEM_COMPILED_PATH
fi
# Don't look in installed dirs for dlopen-able modules
if ( env | grep -v '^GUILE_SYSTEM_EXTENSIONS_PATH=' > /dev/null ); then
GUILE_SYSTEM_EXTENSIONS_PATH=
export GUILE_SYSTEM_EXTENSIONS_PATH
fi
fi
# handle LTDL_LIBRARY_PATH (no clobber)

10
module/Makefile.am
View file

@ -79,10 +79,14 @@ ice-9/psyntax-pp.scm.gen:
.PHONY: ice-9/psyntax-pp.scm.gen
# Keep this rule in sync with that in `am/guilec'.
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
$(AM_V_GUILEC) GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
guild compile $(GUILE_WARNINGS) -o "ice-9/psyntax-pp.go" "$(srcdir)/ice-9/psyntax.scm"
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
-o "ice-9/psyntax-pp.go" "$(srcdir)/ice-9/psyntax.scm"
SCHEME_LANG_SOURCES = \
language/scheme/spec.scm \

61
module/ice-9/boot-9.scm
View file

@ -69,23 +69,6 @@
(define with-throw-handler #f)
(let ()
;; Ideally we'd like to be able to give these default values for all threads,
;; even threads not created by Guile; but alack, that does not currently seem
;; possible. So wrap the getters in thunks.
(define %running-exception-handlers (make-fluid))
(define %exception-handler (make-fluid))
(define (running-exception-handlers)
(or (fluid-ref %running-exception-handlers)
(begin
(fluid-set! %running-exception-handlers '())
'())))
(define (exception-handler)
(or (fluid-ref %exception-handler)
(begin
(fluid-set! %exception-handler default-exception-handler)
default-exception-handler)))
(define (default-exception-handler k . args)
(cond
((eq? k 'quit)
@ -98,18 +81,21 @@
(format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
(primitive-exit 1))))
(define %running-exception-handlers (make-fluid '()))
(define %exception-handler (make-fluid default-exception-handler))
(define (default-throw-handler prompt-tag catch-k)
(let ((prev (exception-handler)))
(let ((prev (fluid-ref %exception-handler)))
(lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
(apply abort-to-prompt prompt-tag thrown-k args)
(apply prev thrown-k args)))))
(define (custom-throw-handler prompt-tag catch-k pre)
(let ((prev (exception-handler)))
(let ((prev (fluid-ref %exception-handler)))
(lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
(let ((running (running-exception-handlers)))
(let ((running (fluid-ref %running-exception-handlers)))
(with-fluids ((%running-exception-handlers (cons pre running)))
(if (not (memq pre running))
(apply pre thrown-k args))
@ -192,9 +178,9 @@ for key @var{key}, then invoke @var{thunk}."
If there is no handler at all, Guile prints an error and then exits."
(if (not (symbol? key))
((exception-handler) 'wrong-type-arg "throw"
((fluid-ref %exception-handler) 'wrong-type-arg "throw"
"Wrong type argument in position ~a: ~a" (list 1 key) (list key))
(apply (exception-handler) key args)))))
(apply (fluid-ref %exception-handler) key args)))))
@ -1404,8 +1390,7 @@ VALUE."
;;; Reader code for various "#c" forms.
;;;
(define read-eval? (make-fluid))
(fluid-set! read-eval? #f)
(define read-eval? (make-fluid #f))
(read-hash-extend #\.
(lambda (c port)
(if (fluid-ref read-eval?)
@ -2843,14 +2828,14 @@ module '(ice-9 q) '(make-q q-length))}."
;;; {Running Repls}
;;;
(define *repl-stack* (make-fluid))
(define *repl-stack* (make-fluid '()))
;; Programs can call `batch-mode?' to see if they are running as part of a
;; script or if they are running interactively. REPL implementations ensure that
;; `batch-mode?' returns #f during their extent.
;;
(define (batch-mode?)
(null? (or (fluid-ref *repl-stack*) '())))
(null? (fluid-ref *repl-stack*)))
;; Programs can re-enter batch mode, for example after a fork, by calling
;; `ensure-batch-mode!'. It's not a great interface, though; it would be better
@ -2889,7 +2874,26 @@ module '(ice-9 q) '(make-q q-length))}."
(define repl-reader
(lambda* (prompt #:optional (reader (fluid-ref current-reader)))
(if (not (char-ready?))
(display (if (string? prompt) prompt (prompt))))
(begin
(display (if (string? prompt) prompt (prompt)))
;; An interesting situation. The printer resets the column to
;; 0 by printing a newline, but we then advance it by printing
;; the prompt. However the port-column of the output port
;; does not typically correspond with the actual column on the
;; screen, because the input is is echoed back! Since the
;; input is line-buffered and thus ends with a newline, the
;; output will really start on column zero. So, here we zero
;; it out. See bug 9664.
;;
;; Note that for similar reasons, the output-line will not
;; reflect the actual line on the screen. But given the
;; possibility of multiline input, the fix is not as
;; straightforward, so we don't bother.
;;
;; Also note that the readline implementation papers over
;; these concerns, because it's readline itself printing the
;; prompt, and not Guile.
(set-port-column! (current-output-port) 0)))
(force-output)
(run-hook before-read-hook)
((or reader read) (current-input-port))))
@ -3241,8 +3245,7 @@ module '(ice-9 q) '(make-q q-length))}."
;;;
(define* (make-mutable-parameter init #:optional (converter identity))
(let ((fluid (make-fluid)))
(fluid-set! fluid (converter init))
(let ((fluid (make-fluid (converter init))))
(case-lambda
(() (fluid-ref fluid))
((val) (fluid-set! fluid (converter val))))))

229
module/ice-9/eval.scm
View file

@ -235,109 +235,127 @@
(inits (if tail (caddr tail) '()))
(alt (and tail (cadddr tail))))
(make-general-closure env body nreq rest nopt kw inits alt))))
(lambda %args
(let lp ((env env)
(nreq* nreq)
(args %args))
(if (> nreq* 0)
;; First, bind required arguments.
(if (null? args)
(if alt
(apply alt-proc %args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))
(lp (cons (car args) env)
(1- nreq*)
(cdr args)))
;; Move on to optional arguments.
(if (not kw)
;; Without keywords, bind optionals from arguments.
(let lp ((env env)
(nopt nopt)
(args args)
(inits inits))
(if (zero? nopt)
(if rest?
(eval body (cons args env))
(if (null? args)
(eval body env)
(if alt
(apply alt-proc %args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))))
(if (null? args)
(lp (cons (eval (car inits) env) env)
(1- nopt) args (cdr inits))
(lp (cons (car args) env)
(1- nopt) (cdr args) (cdr inits)))))
;; With keywords, we stop binding optionals at the first
;; keyword.
(let lp ((env env)
(nopt* nopt)
(args args)
(inits inits))
(if (> nopt* 0)
(if (or (null? args) (keyword? (car args)))
(lp (cons (eval (car inits) env) env)
(1- nopt*) args (cdr inits))
(lp (cons (car args) env)
(1- nopt*) (cdr args) (cdr inits)))
;; Finished with optionals.
(let* ((aok (car kw))
(kw (cdr kw))
(kw-base (+ nopt nreq (if rest? 1 0)))
(imax (let lp ((imax (1- kw-base)) (kw kw))
(if (null? kw)
imax
(lp (max (cdar kw) imax)
(cdr kw)))))
;; Fill in kwargs with "undefined" vals.
(env (let lp ((i kw-base)
;; Also, here we bind the rest
;; arg, if any.
(env (if rest? (cons args env) env)))
(if (<= i imax)
(lp (1+ i) (cons unbound-arg env))
env))))
;; Now scan args for keywords.
(let lp ((args args))
(if (and (pair? args) (pair? (cdr args))
(keyword? (car args)))
(let ((kw-pair (assq (car args) kw))
(v (cadr args)))
(if kw-pair
;; Found a known keyword; set its value.
(list-set! env (- imax (cdr kw-pair)) v)
;; Unknown keyword.
(if (not aok)
(scm-error 'keyword-argument-error
"eval" "Unrecognized keyword"
'() #f)))
(lp (cddr args)))
(if (pair? args)
(if rest?
;; Be lenient parsing rest args.
(lp (cdr args))
(scm-error 'keyword-argument-error
"eval" "Invalid keyword"
'() #f))
;; Finished parsing keywords. Fill in
;; uninitialized kwargs by evalling init
;; expressions in their appropriate
;; environment.
(let lp ((i (- imax kw-base))
(inits inits))
(if (pair? inits)
(let ((tail (list-tail env i)))
(if (eq? (car tail) unbound-arg)
(set-car! tail
(eval (car inits)
(cdr tail))))
(lp (1- i) (cdr inits)))
;; Finally, eval the body.
(eval body env))))))))))))))
(define (set-procedure-arity! proc)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
(set-procedure-minimum-arity! proc nreq nopt rest?)
(let* ((nreq* (cadr alt))
(rest?* (if (null? (cddr alt)) #f (caddr alt)))
(tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
(nopt* (if tail (car tail) 0))
(alt* (and tail (cadddr tail))))
(if (or (< nreq* nreq)
(and (= nreq* nreq)
(if rest?
(and rest?* (> nopt* nopt))
(or rest?* (> nopt* nopt)))))
(lp alt* nreq* nopt* rest?*)
(lp alt* nreq nopt rest?)))))
proc)
(set-procedure-arity!
(lambda %args
(let lp ((env env)
(nreq* nreq)
(args %args))
(if (> nreq* 0)
;; First, bind required arguments.
(if (null? args)
(if alt
(apply alt-proc %args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))
(lp (cons (car args) env)
(1- nreq*)
(cdr args)))
;; Move on to optional arguments.
(if (not kw)
;; Without keywords, bind optionals from arguments.
(let lp ((env env)
(nopt nopt)
(args args)
(inits inits))
(if (zero? nopt)
(if rest?
(eval body (cons args env))
(if (null? args)
(eval body env)
(if alt
(apply alt-proc %args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))))
(if (null? args)
(lp (cons (eval (car inits) env) env)
(1- nopt) args (cdr inits))
(lp (cons (car args) env)
(1- nopt) (cdr args) (cdr inits)))))
;; With keywords, we stop binding optionals at the first
;; keyword.
(let lp ((env env)
(nopt* nopt)
(args args)
(inits inits))
(if (> nopt* 0)
(if (or (null? args) (keyword? (car args)))
(lp (cons (eval (car inits) env) env)
(1- nopt*) args (cdr inits))
(lp (cons (car args) env)
(1- nopt*) (cdr args) (cdr inits)))
;; Finished with optionals.
(let* ((aok (car kw))
(kw (cdr kw))
(kw-base (+ nopt nreq (if rest? 1 0)))
(imax (let lp ((imax (1- kw-base)) (kw kw))
(if (null? kw)
imax
(lp (max (cdar kw) imax)
(cdr kw)))))
;; Fill in kwargs with "undefined" vals.
(env (let lp ((i kw-base)
;; Also, here we bind the rest
;; arg, if any.
(env (if rest? (cons args env) env)))
(if (<= i imax)
(lp (1+ i) (cons unbound-arg env))
env))))
;; Now scan args for keywords.
(let lp ((args args))
(if (and (pair? args) (pair? (cdr args))
(keyword? (car args)))
(let ((kw-pair (assq (car args) kw))
(v (cadr args)))
(if kw-pair
;; Found a known keyword; set its value.
(list-set! env (- imax (cdr kw-pair)) v)
;; Unknown keyword.
(if (not aok)
(scm-error 'keyword-argument-error
"eval" "Unrecognized keyword"
'() #f)))
(lp (cddr args)))
(if (pair? args)
(if rest?
;; Be lenient parsing rest args.
(lp (cdr args))
(scm-error 'keyword-argument-error
"eval" "Invalid keyword"
'() #f))
;; Finished parsing keywords. Fill in
;; uninitialized kwargs by evalling init
;; expressions in their appropriate
;; environment.
(let lp ((i (- imax kw-base))
(inits inits))
(if (pair? inits)
(let ((tail (list-tail env i)))
(if (eq? (car tail) unbound-arg)
(set-car! tail
(eval (car inits)
(cdr tail))))
(lp (1- i) (cdr inits)))
;; Finally, eval the body.
(eval body env)))))))))))))))
;; The "engine". EXP is a memoized expression.
(define (eval exp env)
@ -404,7 +422,10 @@
(memoize-variable-access! exp #f))))
(('define (name . x))
(define! name (eval x env)))
(let ((x (eval x env)))
(if (and (procedure? x) (not (procedure-property x 'name)))
(set-procedure-property! x 'name name))
(define! name x)))
(('toplevel-set! (var-or-sym . x))
(variable-set!

4
module/ice-9/getopt-long.scm
View file

@ -164,9 +164,9 @@
#:use-module (ice-9 optargs)
#:export (getopt-long option-ref))
(define %program-name (make-fluid))
(define %program-name (make-fluid "guile"))
(define (program-name)
(or (fluid-ref %program-name) "guile"))
(fluid-ref %program-name))
(define (fatal-error fmt . args)
(format (current-error-port) "~a: " (program-name))

18024
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

325
module/ice-9/psyntax.scm
View file

@ -952,17 +952,17 @@
;; expanding
(define chi-sequence
(define expand-sequence
(lambda (body r w s mod)
(build-sequence s
(let dobody ((body body) (r r) (w w) (mod mod))
(if (null? body)
'()
(let ((first (chi (car body) r w mod)))
(let ((first (expand (car body) r w mod)))
(cons first (dobody (cdr body) r w mod))))))))
;; At top-level, we allow mixed definitions and expressions. Like
;; chi-body we expand in two passes.
;; expand-body we expand in two passes.
;;
;; First, from left to right, we expand just enough to know what
;; expressions are definitions, syntax definitions, and splicing
@ -975,7 +975,7 @@
;; expansions of all normal definitions and expressions in the
;; sequence.
;;
(define chi-top-sequence
(define expand-top-sequence
(lambda (body r w s m esew mod)
(let* ((r (cons '("placeholder" . (placeholder)) r))
(ribcage (make-empty-ribcage))
@ -1027,11 +1027,11 @@
(record-definition! id var)
(list
(if (eq? m 'c&e)
(let ((x (build-global-definition s var (chi e r w mod))))
(let ((x (build-global-definition s var (expand e r w mod))))
(top-level-eval-hook x mod)
(lambda () x))
(lambda ()
(build-global-definition s var (chi e r w mod)))))))
(build-global-definition s var (expand e r w mod)))))))
((define-syntax-form define-syntax-parameter-form)
(let* ((id (wrap value w mod))
(label (gen-label))
@ -1043,23 +1043,23 @@
((c)
(cond
((memq 'compile esew)
(let ((e (chi-install-global var type (chi e r w mod))))
(let ((e (expand-install-global var type (expand e r w mod))))
(top-level-eval-hook e mod)
(if (memq 'load esew)
(list (lambda () e))
'())))
((memq 'load esew)
(list (lambda ()
(chi-install-global var type (chi e r w mod)))))
(expand-install-global var type (expand e r w mod)))))
(else '())))
((c&e)
(let ((e (chi-install-global var type (chi e r w mod))))
(let ((e (expand-install-global var type (expand e r w mod))))
(top-level-eval-hook e mod)
(list (lambda () e))))
(else
(if (memq 'eval esew)
(top-level-eval-hook
(chi-install-global var type (chi e r w mod))
(expand-install-global var type (expand e r w mod))
mod))
'()))))
((begin-form)
@ -1067,13 +1067,13 @@
((_ e1 ...)
(parse #'(e1 ...) r w s m esew mod))))
((local-syntax-form)
(chi-local-syntax value e r w s mod
(expand-local-syntax value e r w s mod
(lambda (forms r w s mod)
(parse forms r w s m esew mod))))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e #'(x ...) w))
(let ((when-list (parse-when-list e #'(x ...)))
(body #'(e1 e2 ...)))
(define (recurse m esew)
(parse body r w s m esew mod))
@ -1085,7 +1085,7 @@
(begin
(if (memq 'expand when-list)
(top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod)
(expand-top-sequence body r w s 'e '(eval) mod)
mod))
'())))
((memq 'load when-list)
@ -1100,7 +1100,7 @@
(memq 'expand when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod)
(expand-top-sequence body r w s 'e '(eval) mod)
mod)
'())
(else
@ -1108,18 +1108,18 @@
(else
(list
(if (eq? m 'c&e)
(let ((x (chi-expr type value e r w s mod)))
(let ((x (expand-expr type value e r w s mod)))
(top-level-eval-hook x mod)
(lambda () x))
(lambda ()
(chi-expr type value e r w s mod)))))))))
(expand-expr type value e r w s mod)))))))))
(let ((exps (map (lambda (x) (x))
(reverse (parse body r w s m esew mod)))))
(if (null? exps)
(build-void s)
(build-sequence s exps))))))
(define chi-install-global
(define expand-install-global
(lambda (name type e)
(build-global-definition
no-source
@ -1135,24 +1135,21 @@
(build-data no-source 'macro)
e))))))
(define chi-when-list
(lambda (e when-list w)
(define parse-when-list
(lambda (e when-list)
;; `when-list' is syntax'd version of list of situations. We
;; could match these keywords lexically, via free-id=?, but then
;; we twingle the definition of eval-when to the bindings of
;; eval, load, expand, and compile, which is totally unintended.
;; So do a symbolic match instead.
(let f ((when-list when-list) (situations '()))
(if (null? when-list)
situations
(f (cdr when-list)
(cons (let ((x (syntax->datum (car when-list))))
(if (memq x '(compile load eval expand))
x
(syntax-violation 'eval-when
"invalid situation"
e (wrap (car when-list) w #f))))
situations))))))
(let ((result (strip when-list empty-wrap)))
(let lp ((l result))
(if (null? l)
result
(if (memq (car l) '(compile load eval expand))
(lp (cdr l))
(syntax-violation 'eval-when "invalid situation" e
(car l))))))))
;; syntax-type returns six values: type, value, e, w, s, and mod. The
;; first two are described in the table below.
@ -1203,7 +1200,7 @@
((macro)
(if for-car?
(values type value e w s mod)
(syntax-type (chi-macro value e r w s rib mod)
(syntax-type (expand-macro value e r w s rib mod)
r empty-wrap s rib mod #f)))
((global)
;; Toplevel definitions may resolve to bindings with
@ -1225,7 +1222,7 @@
(values 'global-call (make-syntax-object fval w fmod)
e w s mod))
((macro)
(syntax-type (chi-macro fval e r w s rib mod)
(syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?))
((module-ref)
(call-with-values (lambda () (fval e r w))
@ -1279,14 +1276,14 @@
((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod)))))
(define chi
(define expand
(lambda (e r w mod)
(call-with-values
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
(lambda (type value e w s mod)
(chi-expr type value e r w s mod)))))
(expand-expr type value e r w s mod)))))
(define chi-expr
(define expand-expr
(lambda (type value e r w s mod)
(case type
((lexical)
@ -1297,9 +1294,9 @@
((module-ref)
(call-with-values (lambda () (value e r w))
(lambda (e r w s mod)
(chi e r w mod))))
(expand e r w mod))))
((lexical-call)
(chi-call
(expand-call
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id)
@ -1308,7 +1305,7 @@
value))
e r w s mod))
((global-call)
(chi-call
(expand-call
(build-global-reference (source-annotation (car e))
(if (syntax-object? value)
(syntax-object-expression value)
@ -1319,19 +1316,19 @@
e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
((call) (chi-call (chi (car e) r w mod) e r w s mod))
((call) (expand-call (expand (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))))
((local-syntax-form)
(chi-local-syntax value e r w s mod chi-sequence))
(expand-local-syntax value e r w s mod expand-sequence))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e #'(x ...) w)))
(let ((when-list (parse-when-list e #'(x ...))))
(if (memq 'eval when-list)
(chi-sequence #'(e1 e2 ...) r w s mod)
(chi-void))))))
(expand-sequence #'(e1 e2 ...) r w s mod)
(expand-void))))))
((define-form define-syntax-form define-syntax-parameter-form)
(syntax-violation #f "definition in expression context"
e (wrap value w mod)))
@ -1344,12 +1341,12 @@
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
(define chi-call
(define expand-call
(lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
(build-call s x
(map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
(map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
@ -1384,7 +1381,7 @@
;; really nice if we could also annotate introduced expressions with the
;; locations corresponding to the macro definition, but that is not yet
;; possible.
(define chi-macro
(define expand-macro
(lambda (p e r w s rib mod)
(define rebuild-macro-output
(lambda (x m)
@ -1425,7 +1422,7 @@
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
(new-mark))))
(define chi-body
(define expand-body
;; In processing the forms of the body, we create a new, empty wrap.
;; This wrap is augmented (destructively) each time we discover that
;; the next form is a definition. This is done:
@ -1509,19 +1506,19 @@
(f (cdr forms)))))
ids labels var-ids vars vals bindings))))
((local-syntax-form)
(chi-local-syntax value e er w s mod
(lambda (forms er w s mod)
(parse (let f ((forms forms))
(if (null? forms)
(cdr body)
(cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
ids labels var-ids vars vals bindings))))
(expand-local-syntax value e er w s mod
(lambda (forms er w s mod)
(parse (let f ((forms forms))
(if (null? forms)
(cdr body)
(cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
ids labels var-ids vars vals bindings))))
(else ; found a non-definition
(if (null? ids)
(build-sequence no-source
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod))
(expand (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s mod))
(cdr body))))
(begin
@ -1540,7 +1537,7 @@
(macros-only-env er))))
(set-cdr! b
(eval-local-transformer
(chi (cddr b) r-cache empty-wrap mod)
(expand (cddr b) r-cache empty-wrap mod)
mod))
(if (eq? (car b) 'syntax-parameter)
(set-cdr! b (list (cdr b))))
@ -1551,15 +1548,15 @@
(reverse (map syntax->datum var-ids))
(reverse vars)
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod))
(expand (cdr x) (car x) empty-wrap mod))
(reverse vals))
(build-sequence no-source
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod))
(expand (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s mod))
(cdr body)))))))))))))))))
(define chi-local-syntax
(define expand-local-syntax
(lambda (rec? e r w s mod k)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
@ -1576,7 +1573,7 @@
(map (lambda (x)
(make-binding 'macro
(eval-local-transformer
(chi x trans-r w mod)
(expand x trans-r w mod)
mod)))
#'(val ...)))
r)
@ -1593,7 +1590,7 @@
p
(syntax-violation #f "nonprocedure transformer" p)))))
(define chi-void
(define expand-void
(lambda ()
(build-void no-source)))
@ -1623,7 +1620,7 @@
orig-args))))
(req orig-args '())))
(define chi-simple-lambda
(define expand-simple-lambda
(lambda (e r w s mod req rest meta body)
(let* ((ids (if rest (append req (list rest)) req))
(vars (map gen-var ids))
@ -1632,10 +1629,10 @@
s
(map syntax->datum req) (and rest (syntax->datum rest)) vars
meta
(chi-body body (source-wrap e w s mod)
(extend-var-env labels vars r)
(make-binding-wrap ids labels w)
mod)))))
(expand-body body (source-wrap e w s mod)
(extend-var-env labels vars r)
(make-binding-wrap ids labels w)
mod)))))
(define lambda*-formals
(lambda (orig-args)
@ -1718,16 +1715,16 @@
orig-args))))
(req orig-args '())))
(define chi-lambda-case
(define expand-lambda-case
(lambda (e r w s mod get-formals clauses)
(define (expand-req req opt rest kw body)
(define (parse-req req opt rest kw body)
(let ((vars (map gen-var req))
(labels (gen-labels req)))
(let ((r* (extend-var-env labels vars r))
(w* (make-binding-wrap req labels w)))
(expand-opt (map syntax->datum req)
opt rest kw body (reverse vars) r* w* '() '()))))
(define (expand-opt req opt rest kw body vars r* w* out inits)
(parse-opt (map syntax->datum req)
opt rest kw body (reverse vars) r* w* '() '()))))
(define (parse-opt req opt rest kw body vars r* w* out inits)
(cond
((pair? opt)
(syntax-case (car opt) ()
@ -1736,27 +1733,27 @@
(l (gen-labels (list v)))
(r** (extend-var-env l (list v) r*))
(w** (make-binding-wrap (list #'id) l w*)))
(expand-opt req (cdr opt) rest kw body (cons v vars)
r** w** (cons (syntax->datum #'id) out)
(cons (chi #'i r* w* mod) inits))))))
(parse-opt req (cdr opt) rest kw body (cons v vars)
r** w** (cons (syntax->datum #'id) out)
(cons (expand #'i r* w* mod) inits))))))
(rest
(let* ((v (gen-var rest))
(l (gen-labels (list v)))
(r* (extend-var-env l (list v) r*))
(w* (make-binding-wrap (list rest) l w*)))
(expand-kw req (if (pair? out) (reverse out) #f)
(syntax->datum rest)
(if (pair? kw) (cdr kw) kw)
body (cons v vars) r* w*
(if (pair? kw) (car kw) #f)
'() inits)))
(parse-kw req (if (pair? out) (reverse out) #f)
(syntax->datum rest)
(if (pair? kw) (cdr kw) kw)
body (cons v vars) r* w*
(if (pair? kw) (car kw) #f)
'() inits)))
(else
(expand-kw req (if (pair? out) (reverse out) #f) #f
(if (pair? kw) (cdr kw) kw)
body vars r* w*
(if (pair? kw) (car kw) #f)
'() inits))))
(define (expand-kw req opt rest kw body vars r* w* aok out inits)
(parse-kw req (if (pair? out) (reverse out) #f) #f
(if (pair? kw) (cdr kw) kw)
body vars r* w*
(if (pair? kw) (car kw) #f)
'() inits))))
(define (parse-kw req opt rest kw body vars r* w* aok out inits)
(cond
((pair? kw)
(syntax-case (car kw) ()
@ -1765,31 +1762,31 @@
(l (gen-labels (list v)))
(r** (extend-var-env l (list v) r*))
(w** (make-binding-wrap (list #'id) l w*)))
(expand-kw req opt rest (cdr kw) body (cons v vars)
r** w** aok
(cons (list (syntax->datum #'k)
(syntax->datum #'id)
v)
out)
(cons (chi #'i r* w* mod) inits))))))
(parse-kw req opt rest (cdr kw) body (cons v vars)
r** w** aok
(cons (list (syntax->datum #'k)
(syntax->datum #'id)
v)
out)
(cons (expand #'i r* w* mod) inits))))))
(else
(expand-body req opt rest
(if (or aok (pair? out)) (cons aok (reverse out)) #f)
body (reverse vars) r* w* (reverse inits) '()))))
(define (expand-body req opt rest kw body vars r* w* inits meta)
(parse-body req opt rest
(if (or aok (pair? out)) (cons aok (reverse out)) #f)
body (reverse vars) r* w* (reverse inits) '()))))
(define (parse-body req opt rest kw body vars r* w* inits meta)
(syntax-case body ()
((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
(expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
(append meta
`((documentation
. ,(syntax->datum #'docstring))))))
(parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
(append meta
`((documentation
. ,(syntax->datum #'docstring))))))
((#((k . v) ...) e1 e2 ...)
(expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
(append meta (syntax->datum #'((k . v) ...)))))
(parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
(append meta (syntax->datum #'((k . v) ...)))))
((e1 e2 ...)
(values meta req opt rest kw inits vars
(chi-body #'(e1 e2 ...) (source-wrap e w s mod)
r* w* mod)))))
(expand-body #'(e1 e2 ...) (source-wrap e w s mod)
r* w* mod)))))
(syntax-case clauses ()
(() (values '() #f))
@ -1797,12 +1794,12 @@
(call-with-values (lambda () (get-formals #'args))
(lambda (req opt rest kw)
(call-with-values (lambda ()
(expand-req req opt rest kw #'(e1 e2 ...)))
(parse-req req opt rest kw #'(e1 e2 ...)))
(lambda (meta req opt rest kw inits vars body)
(call-with-values
(lambda ()
(chi-lambda-case e r w s mod get-formals
#'((args* e1* e2* ...) ...)))
(expand-lambda-case e r w s mod get-formals
#'((args* e1* e2* ...) ...)))
(lambda (meta* else*)
(values
(append meta meta*)
@ -1900,9 +1897,9 @@
(map (lambda (x)
(make-binding
'macro
(eval-local-transformer (chi x trans-r w mod) mod)))
(eval-local-transformer (expand x trans-r w mod) mod)))
#'(val ...)))))
(chi-body #'(e1 e2 ...)
(expand-body #'(e1 e2 ...)
(source-wrap e w s mod)
(extend-env names bindings r)
w
@ -2094,7 +2091,7 @@
((#((k . v) ...) e1 e2 ...)
(lp #'(e1 e2 ...)
(append meta (syntax->datum #'((k . v) ...)))))
(_ (chi-simple-lambda e r w s mod req rest meta body)))))))
(_ (expand-simple-lambda e r w s mod req rest meta body)))))))
(_ (syntax-violation 'lambda "bad lambda" e)))))
(global-extend 'core 'lambda*
@ -2103,8 +2100,8 @@
((_ args e1 e2 ...)
(call-with-values
(lambda ()
(chi-lambda-case e r w s mod
lambda*-formals #'((args e1 e2 ...))))
(expand-lambda-case e r w s mod
lambda*-formals #'((args e1 e2 ...))))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'lambda "bad lambda*" e)))))
@ -2115,9 +2112,9 @@
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values
(lambda ()
(chi-lambda-case e r w s mod
lambda-formals
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(expand-lambda-case e r w s mod
lambda-formals
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
@ -2128,16 +2125,16 @@
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values
(lambda ()
(chi-lambda-case e r w s mod
lambda*-formals
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(expand-lambda-case e r w s mod
lambda*-formals
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
(global-extend 'core 'let
(let ()
(define (chi-let e r w s mod constructor ids vals exps)
(define (expand-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids))
(syntax-violation 'let "duplicate bound variable" e)
(let ((labels (gen-labels ids))
@ -2147,25 +2144,25 @@
(constructor s
(map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) vals)
(chi-body exps (source-wrap e nw s mod)
nr nw mod))))))
(map (lambda (x) (expand x r w mod)) vals)
(expand-body exps (source-wrap e nw s mod)
nr nw mod))))))
(lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(and-map id? #'(id ...))
(chi-let e r w s mod
build-let
#'(id ...)
#'(val ...)
#'(e1 e2 ...)))
(expand-let e r w s mod
build-let
#'(id ...)
#'(val ...)
#'(e1 e2 ...)))
((_ f ((id val) ...) e1 e2 ...)
(and (id? #'f) (and-map id? #'(id ...)))
(chi-let e r w s mod
build-named-let
#'(f id ...)
#'(val ...)
#'(e1 e2 ...)))
(expand-let e r w s mod
build-named-let
#'(f id ...)
#'(val ...)
#'(e1 e2 ...)))
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
@ -2184,9 +2181,9 @@
(build-letrec s #f
(map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) #'(val ...))
(chi-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod)))))))
(map (lambda (x) (expand x r w mod)) #'(val ...))
(expand-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
@ -2205,9 +2202,9 @@
(build-letrec s #t
(map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) #'(val ...))
(chi-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod)))))))
(map (lambda (x) (expand x r w mod)) #'(val ...))
(expand-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
@ -2223,14 +2220,14 @@
(case type
((lexical)
(build-lexical-assignment s (syntax->datum #'id) value
(chi #'val r w mod)))
(expand #'val r w mod)))
((global)
(build-global-assignment s value (chi #'val r w mod) id-mod))
(build-global-assignment s value (expand #'val r w mod) id-mod))
((macro)
(if (procedure-property value 'variable-transformer)
;; As syntax-type does, call chi-macro with
;; As syntax-type does, call expand-macro with
;; the mod of the expression. Hmm.
(chi (chi-macro value e r w s #f mod) r empty-wrap mod)
(expand (expand-macro value e r w s #f mod) r empty-wrap mod)
(syntax-violation 'set! "not a variable transformer"
(wrap e w mod)
(wrap #'id w id-mod))))
@ -2245,7 +2242,7 @@
(lambda (type value ee ww ss modmod)
(case type
((module-ref)
(let ((val (chi #'val r w mod)))
(let ((val (expand #'val r w mod)))
(call-with-values (lambda () (value #'(head tail ...) r w))
(lambda (e r w s* mod)
(syntax-case e ()
@ -2254,8 +2251,8 @@
val mod)))))))
(else
(build-call s
(chi #'(setter head) r w mod)
(map (lambda (e) (chi e r w mod))
(expand #'(setter head) r w mod)
(map (lambda (e) (expand e r w mod))
#'(tail ... val))))))))
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
@ -2301,15 +2298,15 @@
((_ test then)
(build-conditional
s
(chi #'test r w mod)
(chi #'then r w mod)
(expand #'test r w mod)
(expand #'then r w mod)
(build-void no-source)))
((_ test then else)
(build-conditional
s
(chi #'test r w mod)
(chi #'then r w mod)
(chi #'else r w mod))))))
(expand #'test r w mod)
(expand #'then r w mod)
(expand #'else r w mod))))))
(global-extend 'core 'with-fluids
(lambda (e r w s mod)
@ -2317,10 +2314,10 @@
((_ ((fluid val) ...) b b* ...)
(build-dynlet
s
(map (lambda (x) (chi x r w mod)) #'(fluid ...))
(map (lambda (x) (chi x r w mod)) #'(val ...))
(chi-body #'(b b* ...)
(source-wrap e w s mod) r w mod))))))
(map (lambda (x) (expand x r w mod)) #'(fluid ...))
(map (lambda (x) (expand x r w mod)) #'(val ...))
(expand-body #'(b b* ...)
(source-wrap e w s mod) r w mod))))))
(global-extend 'begin 'begin '())
@ -2410,7 +2407,7 @@
no-source
'apply
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
(chi exp
(expand exp
(extend-env
labels
(map (lambda (var level)
@ -2467,14 +2464,14 @@
(and-map (lambda (x) (not (free-id=? #'pat x)))
(cons #'(... ...) keys)))
(if (free-id=? #'pad #'_)
(chi #'exp r empty-wrap mod)
(expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
(build-call no-source
(build-simple-lambda
no-source (list (syntax->datum #'pat)) #f (list var)
'()
(chi #'exp
(expand #'exp
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
r)
@ -2505,10 +2502,10 @@
#'(key ...) #'(m ...)
r
mod))
(list (chi #'val r empty-wrap mod))))
(list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))))))))
;; The portable macroexpand seeds chi-top's mode m with 'e (for
;; The portable macroexpand seeds expand-top's mode m with 'e (for
;; evaluating) and esew (which stands for "eval syntax expanders
;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
;; if we are compiling a file, and esew is set to
@ -2519,8 +2516,8 @@
;; the object file if we are compiling a file.
(set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval)))
(chi-top-sequence (list x) null-env top-wrap #f m esew
(cons 'hygiene (module-name (current-module))))))
(expand-top-sequence (list x) null-env top-wrap #f m esew
(cons 'hygiene (module-name (current-module))))))
(set! identifier?
(lambda (x)

4
module/ice-9/vlist.scm
View file

@ -66,9 +66,7 @@
;;;
(define block-growth-factor
(let ((f (make-fluid)))
(fluid-set! f 2)
f))
(make-fluid 2))
(define-syntax-rule (define-inline (name formals ...) body ...)
;; Work around the lack of an inliner.

14
module/language/elisp/runtime.scm
View file

@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;; 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
@ -131,8 +131,8 @@
((_ name value)
(with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
#'(begin
(define-public scheme-name (make-fluid))
(fluid-set! scheme-name (cons 'macro value))))))))
(define-public scheme-name
(make-fluid (cons 'macro value)))))))))
(define-syntax defspecial
(lambda (x)
@ -140,10 +140,10 @@
((_ name args body ...)
(with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
#'(begin
(define scheme-name (make-fluid))
(fluid-set! scheme-name
(cons 'special-operator
(lambda args body ...)))))))))
(define scheme-name
(make-fluid
(cons 'special-operator
(lambda args body ...))))))))))
;;; Call a guile-primitive that may be rebound for elisp and thus needs
;;; absolute addressing.

24
module/scripts/compile.scm
View file

@ -30,6 +30,7 @@
(define-module (scripts compile)
#:use-module ((system base compile) #:select (compile-file))
#:use-module (system base target)
#:use-module (system base message)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
@ -88,7 +89,12 @@
(lambda (opt name arg result)
(if (assoc-ref result 'to)
(fail "`--to' option cannot be specified more than once")
(alist-cons 'to (string->symbol arg) result))))))
(alist-cons 'to (string->symbol arg) result))))
(option '(#\T "target") #t #f
(lambda (opt name arg result)
(if (assoc-ref result 'target)
(fail "`--target' option cannot be specified more than once")
(alist-cons 'target arg result))))))
(define (parse-args args)
"Parse argument list @var{args} and return an alist with all the relevant
@ -109,7 +115,7 @@ options."
(define (show-version)
(format #t "compile (GNU Guile) ~A~%" (version))
(format #t "Copyright (C) 2009 Free Software Foundation, Inc.
(format #t "Copyright (C) 2009, 2011 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.~%"))
@ -134,6 +140,7 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
o)))
(from (or (assoc-ref options 'from) 'scheme))
(to (or (assoc-ref options 'to) 'objcode))
(target (or (assoc-ref options 'target) %host-type))
(input-files (assoc-ref options 'input-files))
(output-file (assoc-ref options 'output-file))
(load-path (assoc-ref options 'load-path)))
@ -152,6 +159,7 @@ Compile each Guile source file FILE into a Guile object.
-f, --from=LANG specify a source language other than `scheme'
-t, --to=LANG specify a target language other than `objcode'
-T, --target=TRIPLET produce bytecode for host TRIPLET
Note that auto-compilation will be turned off.
@ -171,11 +179,13 @@ Report bugs to <~A>.~%"
(for-each (lambda (file)
(format #t "wrote `~A'\n"
(with-fluids ((*current-warning-prefix* ""))
(compile-file file
#:output-file output-file
#:from from
#:to to
#:opts compile-opts))))
(with-target target
(lambda ()
(compile-file file
#:output-file output-file
#:from from
#:to to
#:opts compile-opts))))))
input-files)))
(define main compile)

50
module/srfi/srfi-39.scm
View file

@ -57,37 +57,41 @@
(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
(define (make-parameter/helper val conv)
(let ((value (make-fluid))
(conv conv))
(begin
(fluid-set! value (conv val))
(lambda new-value
(cond
((null? new-value) (fluid-ref value))
((eq? (car new-value) get-fluid-tag) value)
((eq? (car new-value) get-conv-tag) conv)
((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
(else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
(let ((fluid (make-fluid (conv val))))
(case-lambda
(()
(fluid-ref fluid))
((new-value)
(cond
((eq? new-value get-fluid-tag) fluid)
((eq? new-value get-conv-tag) conv)
(else (fluid-set! fluid (conv new-value))))))))
(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
(with-parameters* (list ?param ...)
(list ?value ...)
(lambda () ?body ...)))
(define (current-input-port . new-value)
(if (null? new-value)
((@ (guile) current-input-port))
(apply set-current-input-port new-value)))
(define current-input-port
(case-lambda
(()
((@ (guile) current-input-port)))
((new-value)
(set-current-input-port new-value))))
(define (current-output-port . new-value)
(if (null? new-value)
((@ (guile) current-output-port))
(apply set-current-output-port new-value)))
(define current-output-port
(case-lambda
(()
((@ (guile) current-output-port)))
((new-value)
(set-current-output-port new-value))))
(define (current-error-port . new-value)
(if (null? new-value)
((@ (guile) current-error-port))
(apply set-current-error-port new-value)))
(define current-error-port
(case-lambda
(()
((@ (guile) current-error-port)))
((new-value)
(set-current-error-port new-value))))
(define port-list
(list current-input-port current-output-port current-error-port))

4
module/system/base/language.scm
View file

@ -111,7 +111,7 @@
;;; Current language
;;;
(define *current-language* (make-fluid))
(define *current-language* (make-fluid 'scheme))
(define (current-language)
(or (fluid-ref *current-language*) 'scheme))
(fluid-ref *current-language*))

6
module/system/base/message.scm
View file

@ -56,15 +56,13 @@
(define *current-warning-port*
;; The port where warnings are sent.
(make-fluid))
(make-fluid (current-error-port)))
(fluid-set! *current-warning-port* (current-error-port))
(define *current-warning-prefix*
;; Prefix string when emitting a warning.
(make-fluid))
(fluid-set! *current-warning-prefix* ";;; ")
(make-fluid ";;; "))
(define-record-type <warning-type>

91
module/system/base/target.scm
View file

@ -21,6 +21,7 @@
(define-module (system base target)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 regex)
#:export (target-type with-target
target-cpu target-vendor target-os
@ -33,44 +34,90 @@
;;; Target types
;;;
(define %target-type (make-fluid))
(define %native-word-size
;; The native word size. Note: don't use `word-size' from
;; (system vm objcode) to avoid a circular dependency.
((@ (system foreign) sizeof) '*))
(define (target-type)
(or (fluid-ref %target-type)
%host-type))
(define %target-type (make-fluid %host-type))
(define %target-endianness (make-fluid (native-endianness)))
(define %target-word-size (make-fluid %native-word-size))
(define (validate-target target)
(if (or (not (string? target))
(let ((parts (string-split target #\-)))
(or (< 3 (length parts))
(or (< (length parts) 3)
(or-map string-null? parts))))
(error "invalid target" target)))
(define (with-target target thunk)
(validate-target target)
(with-fluids ((%target-type target))
(thunk)))
(let ((cpu (triplet-cpu target)))
(with-fluids ((%target-type target)
(%target-endianness (cpu-endianness cpu))
(%target-word-size (cpu-word-size cpu)))
(thunk))))
(define (target-cpu)
(let ((t (target-type)))
(substring t 0 (string-index t #\-))))
(define (cpu-endianness cpu)
"Return the endianness for CPU."
(if (string=? cpu (triplet-cpu %host-type))
(native-endianness)
(cond ((string-match "^i[0-9]86$" cpu)
(endianness little))
((member cpu '("x86_64" "ia64"
"powerpcle" "powerpc64le" "mipsel" "mips64el"))
(endianness little))
((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu"
"mips" "mips64"))
(endianness big))
((string-match "^arm.*el" cpu)
(endianness little))
(else
(error "unknown CPU endianness" cpu)))))
(define (target-vendor)
(let* ((t (target-type))
(start (1+ (string-index t #\-))))
(define (cpu-word-size cpu)
"Return the word size for CPU."
(if (string=? cpu (triplet-cpu %host-type))
%native-word-size
(cond ((string-match "^i[0-9]86$" cpu) 4)
((string-match "64$" cpu) 8)
((string-match "64[lbe][lbe]$" cpu) 8)
((member cpu '("sparc" "powerpc" "mips")) 4)
((string-match "^arm.*" cpu) 4)
(else "unknown CPU word size" cpu))))
(define (triplet-cpu t)
(substring t 0 (string-index t #\-)))
(define (triplet-vendor t)
(let ((start (1+ (string-index t #\-))))
(substring t start (string-index t #\- start))))
(define (target-os)
(let* ((t (target-type))
(start (1+ (string-index t #\- (1+ (string-index t #\-))))))
(define (triplet-os t)
(let ((start (1+ (string-index t #\- (1+ (string-index t #\-))))))
(substring t start)))
(define (target-type)
"Return the GNU configuration triplet of the target platform."
(fluid-ref %target-type))
(define (target-cpu)
"Return the CPU name of the target platform."
(triplet-cpu (target-type)))
(define (target-vendor)
"Return the vendor name of the target platform."
(triplet-vendor (target-type)))
(define (target-os)
"Return the operating system name of the target platform."
(triplet-os (target-type)))
(define (target-endianness)
(if (equal? (target-type) %host-type)
(native-endianness)
(error "cross-compilation not yet handled" %host-type (target-type))))
"Return the endianness object of the target platform."
(fluid-ref %target-endianness))
(define (target-word-size)
(if (equal? (target-type) %host-type)
((@ (system foreign) sizeof) '*)
(error "cross-compilation not yet handled" %host-type (target-type))))
"Return the word size, in bytes, of the target platform."
(fluid-ref %target-word-size))

4
module/system/repl/common.scm
View file

@ -134,7 +134,9 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(define %make-repl make-repl)
(define* (make-repl lang #:optional debug)
(%make-repl #:language (lookup-language lang)
(%make-repl #:language (if (language? lang)
lang
(lookup-language lang))
#:options (copy-tree repl-default-options)
#:tm-stats (times)
#:gc-stats (gc-stats)

10
module/texinfo/plain-text.scm
View file

@ -1,6 +1,6 @@
;;;; (texinfo plain-text) -- rendering stexinfo as plain text
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -41,9 +41,6 @@
(or (arg-ref key %-args)
(error "Missing argument:" key %-args)))
(define *indent* (make-fluid))
(define *itemizer* (make-fluid))
(define (make-ticker str)
(lambda () str))
(define (make-enumerator n)
@ -52,9 +49,8 @@
(set! n (1+ n))
(format #f "~A. " last))))
(fluid-set! *indent* "")
;; Shouldn't be necessary to do this, but just in case.
(fluid-set! *itemizer* (make-ticker "* "))
(define *indent* (make-fluid ""))
(define *itemizer* (make-fluid (make-ticker "* ")))
(define-macro (with-indent n . body)
`(with-fluids ((*indent* (string-append (fluid-ref *indent*)

26
module/web/http.scm
View file

@ -470,7 +470,7 @@ ordered alist."
val)
(define (default-val-validator k val)
(string? val))
(or (not val) (string? val)))
(define (default-val-writer k val port)
(if (or (string-index val #\;)
@ -518,9 +518,9 @@ ordered alist."
((pair? elt)
(let ((k (car elt))
(v (cdr elt)))
(and (or (string? k) (symbol? k))
(and (symbol? k)
(valid? k v))))
((or (string? elt) (symbol? elt))
((symbol? elt)
(valid? elt #f))
(else #f)))))
@ -611,7 +611,7 @@ ordered alist."
(valid? default-val-validator))
(list-of? list
(lambda (elt)
(key-value-list? list valid?))))
(key-value-list? elt valid?))))
(define* (write-param-list list port #:optional
(val-writer default-val-writer))
@ -871,7 +871,10 @@ ordered alist."
(cons scheme (parse-key-value-list str default-val-parser delim end)))))))
(define (validate-credentials val)
(and (pair? val) (symbol? (car val)) (key-value-list? (cdr val))))
(and (pair? val) (symbol? (car val))
(case (car val)
((basic) (string? (cdr val)))
(else (key-value-list? (cdr val))))))
(define (write-credentials val port)
(display (car val) port)
@ -1137,7 +1140,7 @@ phrase\"."
(lambda (str)
(map string->symbol (split-and-trim str)))
(lambda (v)
(list-of? symbol? v))
(list-of? v symbol?))
(lambda (v port)
(write-list v port display ", "))))
@ -1242,7 +1245,14 @@ phrase\"."
((private no-cache)
(and v-str (split-header-names v-str)))
(else v-str)))
default-val-validator
(lambda (k v)
(case k
((max-age max-stale min-fresh s-maxage)
(non-negative-integer? v))
((private no-cache)
(or (not v) (list-of-header-names? v)))
(else
(not v))))
(lambda (k v port)
(cond
((string? v) (display v port))
@ -1522,7 +1532,7 @@ phrase\"."
(lambda (k v)
(if (eq? k 'q)
(valid-quality? v)
(string? v)))
(or (not v) (string? v))))
(lambda (k v port)
(if (eq? k 'q)
(write-quality v port)

3
test-suite/lib.scm
View file

@ -425,8 +425,7 @@
(append (current-test-prefix) (list name)))
;;; A fluid containing the current test prefix, as a list.
(define prefix-fluid (make-fluid))
(fluid-set! prefix-fluid '())
(define prefix-fluid (make-fluid '()))
(define (current-test-prefix)
(fluid-ref prefix-fluid))

85
test-suite/tests/asm-to-bytecode.test
View file

@ -1,15 +1,17 @@
;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 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
@ -19,6 +21,8 @@
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
#:use-module (system base target)
#:use-module (language assembly)
#:use-module (language assembly compile-bytecode))
@ -114,3 +118,80 @@
(uint32 0) ;; metalen
make-int8 3
return))))
(define (test-triplet cpu vendor os)
(let ((triplet (string-append cpu "-" vendor "-" os)))
(pass-if (format #f "triplet ~a" triplet)
(with-target triplet
(lambda ()
(and (string=? (target-cpu) cpu)
(string=? (target-vendor) vendor)
(string=? (target-os) os)))))))
(define %objcode-cookie-size
(string-length "GOOF----LE-8-2.0"))
(define (test-target triplet endian word-size)
(pass-if (format #f "target `~a' honored" triplet)
(call-with-values (lambda ()
(open-bytevector-output-port))
(lambda (p get-objcode)
(with-target triplet
(lambda ()
(let ((b (compile-bytecode
'(load-program () 16 #f
(assert-nargs-ee/locals 1)
(make-int8 77)
(toplevel-ref 1)
(local-ref 0)
(mul)
(add)
(return)
(nop) (nop) (nop)
(nop) (nop))
#f)))
(write-objcode (bytecode->objcode b) p)
(let ((cookie (make-bytevector %objcode-cookie-size))
(expected (format #f "GOOF----~a-~a-~a"
(cond ((eq? endian (endianness little))
"LE")
((eq? endian (endianness big))
"BE")
(else
(error "unknown endianness"
endian)))
word-size
(effective-version))))
(bytevector-copy! (get-objcode) 0 cookie 0
%objcode-cookie-size)
(string=? (utf8->string cookie) expected)))))))))
(with-test-prefix "cross-compilation"
(test-triplet "i586" "pc" "gnu0.3")
(test-triplet "x86_64" "unknown" "linux-gnu")
(test-triplet "x86_64" "unknown" "kfreebsd-gnu")
(test-target "i586-pc-gnu0.3" (endianness little) 4)
(test-target "x86_64-pc-linux-gnu" (endianness little) 8)
(test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
(test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
(pass-if-exception "unknown target"
exception:miscellaneous-error
(call-with-values (lambda ()
(open-bytevector-output-port))
(lambda (p get-objcode)
(let* ((b (compile-bytecode '(load-program () 3 #f
(make-int8 77)
(return))
#f))
(o (bytecode->objcode b)))
(with-target "fcpu-unknown-gnu1.0"
(lambda ()
(write-objcode o p))))))))
;; Local Variables:
;; eval: (put 'with-target 'scheme-indent-function 1)
;; End:

11
test-suite/tests/bytevectors.test
View file

@ -1,6 +1,6 @@
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -42,7 +42,14 @@
(and (bytevector=? (make-bytevector 20 7)
(make-bytevector 20 7))
(not (bytevector=? (make-bytevector 20 7)
(make-bytevector 20 0))))))
(make-bytevector 20 0)))))
(pass-if "bytevector-copy! overlapping"
;; See <http://debbugs.gnu.org/10070>.
(let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))
(bytevector-copy! b 0 b 3 4)
(bytevector->u8-list b)
(bytevector=? b #vu8(1 2 3 1 2 3 4 8)))))
(with-test-prefix/c&e "2.3 Operations on Bytes and Octets"

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

@ -231,10 +231,10 @@
(with-test-prefix "define set procedure-name"
(expect-fail "closure"
(pass-if "closure"
(eq? 'foo-closure (procedure-name bar-closure)))
(expect-fail "procedure-with-setter"
(expect-fail "procedure-with-setter" ; FIXME: `pass-if' when it's supported
(eq? 'foo-pws (procedure-name bar-pws))))
;;;
@ -330,78 +330,49 @@
0))
(with-test-prefix "stacks"
(with-debugging-evaluator
(pass-if "stack involving a primitive"
;; The primitive involving the error must appear exactly once on the
;; stack.
(catch 'result
(lambda ()
(start-stack 'foo
(with-throw-handler 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(hashq-ref 'wrong 'type 'arg))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(count (lambda (frame)
(eq? (frame-procedure frame)
hashq-ref))
frames)))))))
(lambda (key result)
(= 1 result))))
(pass-if "stack involving a subr"
;; The subr involving the error must appear exactly once on the stack.
(catch 'result
(lambda ()
(throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(fluid-ref 'not-a-fluid))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(count (lambda (frame)
(and (frame-procedure? frame)
(eq? (frame-procedure frame)
fluid-ref)))
frames)))))))
(lambda (key result)
(= 1 result))))
(pass-if "stack involving a gsubr"
;; The gsubr involving the error must appear exactly once on the stack.
;; This is less obvious since gsubr application may require an
;; additional `SCM_APPLY ()' call, which should not be visible to the
;; application.
(catch 'result
(lambda ()
(throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(hashq-ref 'wrong 'type 'arg))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(count (lambda (frame)
(and (frame-procedure? frame)
(eq? (frame-procedure frame)
hashq-ref)))
frames)))))))
(lambda (key result)
(= 1 result))))
(pass-if "arguments of a gsubr stack frame"
;; Create a stack with two gsubr frames and make sure the arguments are
;; correct.
(catch 'result
(lambda ()
(throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(substring 'wrong 'type 'arg))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(map (lambda (frame)
(cons (frame-procedure frame)
(frame-arguments frame)))
frames)))))))
(lambda (key result)
(and (equal? (car result) `(,make-stack #t))
(pair? (member `(,substring wrong type arg)
(cdr result)))))))))
(pass-if "arguments of a primitive stack frame"
;; Create a stack with two primitive frames and make sure the
;; arguments are correct.
(catch 'result
(lambda ()
(start-stack 'foo
(with-throw-handler 'wrong-type-arg
(lambda ()
;; Trigger a `wrong-type-arg' exception.
(substring 'wrong 'type 'arg))
(lambda _
(let* ((stack (make-stack #t))
(frames (stack->frames stack)))
(throw 'result
(map (lambda (frame)
(cons (frame-procedure frame)
(frame-arguments frame)))
frames)))))))
(lambda (key result)
(and (equal? (car result) `(,make-stack #t))
(pair? (member `(,substring wrong type arg)
(cdr result))))))))
;;;
;;; letrec init evaluation

26
test-suite/tests/foreign.test
View file

@ -254,6 +254,16 @@
(map proc* arg1 arg2 arg3)))
(throw 'unresolved)))
(pass-if "procedures returning a pointer"
(if (defined? 'procedure->pointer)
(let* ((called? #f)
(proc (lambda (i) (set! called? #t) (make-pointer i)))
(pointer (procedure->pointer '* proc (list int)))
(proc* (pointer->procedure '* pointer (list int)))
(result (proc* 777)))
(and called? (equal? result (make-pointer 777))))
(throw 'unresolved)))
(pass-if "procedures returning void"
(if (defined? 'procedure->pointer)
(let* ((called? #f)
@ -262,6 +272,22 @@
(proc* (pointer->procedure void pointer '())))
(proc*)
called?)
(throw 'unresolved)))
(pass-if "procedure is retained"
;; The lambda passed to `procedure->pointer' must remain live.
(if (defined? 'procedure->pointer)
(let* ((ptr (procedure->pointer int
(lambda (x) (+ x 7))
(list int)))
(procs (unfold (cut >= <> 10000)
(lambda (i)
(pointer->procedure int ptr (list int)))
1+
0)))
(gc) (gc) (gc)
(every (cut = <> 9)
(map (lambda (f) (f 2)) procs)))
(throw 'unresolved))))

26
test-suite/tests/procprop.test
View file

@ -1,7 +1,7 @@
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; 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
@ -26,7 +26,12 @@
(eq? 'display (procedure-name display)))
(pass-if "gsubr"
(eq? 'hashq-ref (procedure-name hashq-ref))))
(eq? 'hashq-ref (procedure-name hashq-ref)))
(pass-if "from eval"
(eq? 'foobar (procedure-name
(eval '(begin (define (foobar) #t) foobar)
(current-module))))))
(with-test-prefix "procedure-arity"
@ -52,4 +57,19 @@
(pass-if "list"
(equal? (procedure-minimum-arity list)
'(0 0 #t))))
'(0 0 #t)))
(pass-if "fixed, eval"
(equal? (procedure-minimum-arity (eval '(lambda (a b) #t)
(current-module)))
'(2 0 #f)))
(pass-if "rest, eval"
(equal? (procedure-minimum-arity (eval '(lambda (a b . c) #t)
(current-module)))
'(2 0 #t)))
(pass-if "opt, eval"
(equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t)
(current-module)))
'(2 1 #f))))

5
test-suite/tests/web-http.test
View file

@ -41,8 +41,9 @@
(syntax-rules ()
((_ sym str val)
(pass-if (format #f "~a: ~s -> ~s" 'sym str val)
(equal? (parse-header 'sym str)
val)))))
(and (equal? (parse-header 'sym str)
val)
(valid-header? 'sym val))))))
(define-syntax pass-if-any-error
(syntax-rules ()