mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-28 16:00:22 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
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
commit
b2208d2e98
54 changed files with 10211 additions and 9681 deletions
23
README
23
README
|
|
@ -239,25 +239,28 @@ switches specific to Guile you may find useful in some circumstances.
|
||||||
|
|
||||||
Cross building Guile =====================================================
|
Cross building Guile =====================================================
|
||||||
|
|
||||||
As of guile-1.5.x, the build process uses compiled C files for
|
As of Guile 2.0.x, the build process produces a library, libguile-2.0,
|
||||||
snarfing, and (indirectly, through libtool) for linking, and uses the
|
along with Guile "object files" containing bytecode to be interpreted by
|
||||||
guile executable for generating documentation.
|
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
|
Thus, when cross building Guile, you first need to configure, build and
|
||||||
install guile for your build host.
|
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
|
./configure --host=i686-pc-cygwin --disable-shared
|
||||||
|
|
||||||
A C compiler for the build system is required. The default is
|
A C compiler for the build system is required. If that doesn't suit it
|
||||||
"PATH=/usr/bin:$PATH cc". If that doesn't suit it can be specified
|
can be specified with the CC_FOR_BUILD variable in the usual way, for
|
||||||
with the CC_FOR_BUILD variable in the usual way, for instance
|
instance:
|
||||||
|
|
||||||
./configure --host=m68k-unknown-linux-gnu CC_FOR_BUILD=/my/local/gcc
|
./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 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 =========================================
|
Using Guile Without Installing It =========================================
|
||||||
|
|
|
||||||
50
acinclude.m4
50
acinclude.m4
|
|
@ -530,6 +530,56 @@ AC_DEFUN([GUILE_UNISTRING_ICONVEH_VALUES], [
|
||||||
GUILE_UNISTRING_CONSTANT([iconveh_escape_sequence])
|
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 Declare file $1 to be a script that needs configuring,
|
||||||
dnl and arrange to make it executable in the process.
|
dnl and arrange to make it executable in the process.
|
||||||
AC_DEFUN([GUILE_CONFIG_SCRIPT],[AC_CONFIG_FILES([$1],[chmod +x $1])])
|
AC_DEFUN([GUILE_CONFIG_SCRIPT],[AC_CONFIG_FILES([$1],[chmod +x $1])])
|
||||||
|
|
|
||||||
|
|
@ -26,6 +26,9 @@ AM_V_GUILEC_0 = @echo " GUILEC" $@;
|
||||||
|
|
||||||
SUFFIXES = .scm .go
|
SUFFIXES = .scm .go
|
||||||
.scm.go:
|
.scm.go:
|
||||||
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
|
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
|
||||||
$(top_builddir)/meta/uninstalled-env \
|
$(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 "$@" "$<"
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
;;;; benchmark-suite/lib.scm --- generic support for benchmarking
|
;;;; 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
|
;;;; This program is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -348,8 +348,7 @@
|
||||||
(append (current-benchmark-prefix) (list name)))
|
(append (current-benchmark-prefix) (list name)))
|
||||||
|
|
||||||
;;; A fluid containing the current benchmark prefix, as a list.
|
;;; A fluid containing the current benchmark prefix, as a list.
|
||||||
(define prefix-fluid (make-fluid))
|
(define prefix-fluid (make-fluid '()))
|
||||||
(fluid-set! prefix-fluid '())
|
|
||||||
(define (current-benchmark-prefix)
|
(define (current-benchmark-prefix)
|
||||||
(fluid-ref prefix-fluid))
|
(fluid-ref prefix-fluid))
|
||||||
|
|
||||||
|
|
|
||||||
17
configure.ac
17
configure.ac
|
|
@ -1259,7 +1259,7 @@ save_LIBS="$LIBS"
|
||||||
LIBS="$BDW_GC_LIBS $LIBS"
|
LIBS="$BDW_GC_LIBS $LIBS"
|
||||||
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
|
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
|
# 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
|
# declared, and has a different type (returning void instead of
|
||||||
|
|
@ -1511,20 +1511,7 @@ AC_SUBST(CCLD_FOR_BUILD)
|
||||||
HOST_CC="$CC_FOR_BUILD"
|
HOST_CC="$CC_FOR_BUILD"
|
||||||
AC_SUBST(HOST_CC)
|
AC_SUBST(HOST_CC)
|
||||||
|
|
||||||
if test "$cross_compiling" = "yes"; then
|
GUILE_CHECK_GUILE_FOR_BUILD
|
||||||
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)
|
|
||||||
|
|
||||||
## If we're using GCC, ask for aggressive warnings.
|
## If we're using GCC, ask for aggressive warnings.
|
||||||
GCC_CFLAGS=""
|
GCC_CFLAGS=""
|
||||||
|
|
|
||||||
|
|
@ -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)
|
@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
|
Copy @var{len} bytes from @var{source} into @var{target}, starting
|
||||||
reading from @var{source-start} (a positive index within @var{source})
|
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
|
@end deffn
|
||||||
|
|
||||||
@deffn {Scheme Procedure} bytevector-copy bv
|
@deffn {Scheme Procedure} bytevector-copy bv
|
||||||
|
|
|
||||||
|
|
@ -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,
|
Use @var{lang} as the target language of @var{file}. If this option is omitted,
|
||||||
@code{objcode} is assumed.
|
@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
|
@end table
|
||||||
|
|
||||||
Each @var{file} is assumed to be UTF-8-encoded, unless it contains a
|
Each @var{file} is assumed to be UTF-8-encoded, unless it contains a
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
@c -*-texinfo-*-
|
@c -*-texinfo-*-
|
||||||
@c This is part of the GNU Guile Reference Manual.
|
@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 Free Software Foundation, Inc.
|
||||||
@c See the file guile.texi for copying conditions.
|
@c See the file guile.texi for copying conditions.
|
||||||
|
|
||||||
|
|
@ -8,9 +8,9 @@
|
||||||
@chapter Introduction
|
@chapter Introduction
|
||||||
|
|
||||||
Guile is an implementation of the Scheme programming language. Scheme
|
Guile is an implementation of the Scheme programming language. Scheme
|
||||||
(@url{schemers.org}) is an elegant and conceptually simple dialect of
|
(@url{http://schemers.org/}) is an elegant and conceptually simple
|
||||||
Lisp, originated by Guy Steele and Gerald Sussman, and since evolved
|
dialect of Lisp, originated by Guy Steele and Gerald Sussman, and since
|
||||||
by the series of reports known as RnRS (the
|
evolved by the series of reports known as RnRS (the
|
||||||
@tex
|
@tex
|
||||||
Revised$^n$
|
Revised$^n$
|
||||||
@end tex
|
@end tex
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
@c -*-texinfo-*-
|
@c -*-texinfo-*-
|
||||||
@c This is part of the GNU Guile Reference Manual.
|
@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 Free Software Foundation, Inc.
|
||||||
@c See the file guile.texi for copying conditions.
|
@c See the file guile.texi for copying conditions.
|
||||||
|
|
||||||
|
|
@ -10,7 +10,7 @@
|
||||||
@itemize @bullet
|
@itemize @bullet
|
||||||
|
|
||||||
@item
|
@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.
|
all things Scheme.
|
||||||
|
|
||||||
@item
|
@item
|
||||||
|
|
|
||||||
|
|
@ -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
|
over the available SRFIs and some usage hints. For complete
|
||||||
documentation, design rationales and further examples, we advise you to
|
documentation, design rationales and further examples, we advise you to
|
||||||
get the relevant SRFI documents from the SRFI home page
|
get the relevant SRFI documents from the SRFI home page
|
||||||
@url{http://srfi.schemers.org}.
|
@url{http://srfi.schemers.org/}.
|
||||||
|
|
||||||
@menu
|
@menu
|
||||||
* About SRFI Usage:: What to know about Guile's SRFI support.
|
* About SRFI Usage:: What to know about Guile's SRFI support.
|
||||||
|
|
|
||||||
|
|
@ -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
|
Indicates that a response should proceed if and only if the resource has
|
||||||
been modified since the given date.
|
been modified since the given date.
|
||||||
@example
|
@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 ...>
|
@result{} #<date ...>
|
||||||
@end example
|
@end example
|
||||||
@end deftypevr
|
@end deftypevr
|
||||||
|
|
|
||||||
|
|
@ -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))
|
if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
|
||||||
scm_out_of_range (FUNC_NAME, target_start);
|
scm_out_of_range (FUNC_NAME, target_start);
|
||||||
|
|
||||||
memcpy (c_target + c_target_start,
|
memmove (c_target + c_target_start,
|
||||||
c_source + c_source_start,
|
c_source + c_source_start,
|
||||||
c_len);
|
c_len);
|
||||||
|
|
||||||
return SCM_UNSPECIFIED;
|
return SCM_UNSPECIFIED;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -68,7 +68,7 @@ grow_dynamic_state (SCM state)
|
||||||
/* Assume the assignment below is atomic. */
|
/* Assume the assignment below is atomic. */
|
||||||
len = allocated_fluids_len;
|
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++)
|
for (i = 0; i < old_len; i++)
|
||||||
SCM_SIMPLE_VECTOR_SET (new_fluids, 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. */
|
/* Return a new fluid. */
|
||||||
static SCM
|
static SCM
|
||||||
new_fluid ()
|
new_fluid (SCM init)
|
||||||
{
|
{
|
||||||
SCM fluid;
|
SCM fluid;
|
||||||
size_t trial, n;
|
size_t trial, n;
|
||||||
|
|
||||||
/* Fluids are pointerless cells: the first word is the type tag; the second
|
/* Fluids hold the type tag and the fluid number in the first word,
|
||||||
word is the fluid number. */
|
and the default value in the second word. */
|
||||||
fluid = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_cell), "fluid"));
|
fluid = scm_cell (scm_tc7_fluid, SCM_UNPACK (init));
|
||||||
SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid);
|
SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid);
|
||||||
|
|
||||||
scm_dynwind_begin (0);
|
scm_dynwind_begin (0);
|
||||||
|
|
@ -157,7 +157,7 @@ new_fluid ()
|
||||||
}
|
}
|
||||||
|
|
||||||
allocated_fluids[n] = SCM_UNPACK_POINTER (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],
|
GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n],
|
||||||
SCM_HEAP_OBJECT_BASE (fluid));
|
SCM_HEAP_OBJECT_BASE (fluid));
|
||||||
|
|
@ -166,13 +166,19 @@ new_fluid ()
|
||||||
|
|
||||||
/* Now null out values. We could (and probably should) do this when
|
/* Now null out values. We could (and probably should) do this when
|
||||||
the fluid is collected instead of now. */
|
the fluid is collected instead of now. */
|
||||||
scm_i_reset_fluid (n, SCM_BOOL_F);
|
scm_i_reset_fluid (n);
|
||||||
|
|
||||||
return fluid;
|
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"
|
"Return a newly created fluid.\n"
|
||||||
"Fluids are objects that can hold one\n"
|
"Fluids are objects that can hold one\n"
|
||||||
"value per dynamic state. That is, modifications to this value are\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"
|
"the modifying code. When a new dynamic state is constructed, it\n"
|
||||||
"inherits the values from its parent. Because each thread normally executes\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.")
|
"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
|
#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.")
|
"Make a fluid that is initially unbound.")
|
||||||
#define FUNC_NAME s_scm_make_unbound_fluid
|
#define FUNC_NAME s_scm_make_unbound_fluid
|
||||||
{
|
{
|
||||||
SCM f = new_fluid ();
|
return new_fluid (SCM_UNDEFINED);
|
||||||
scm_fluid_set_x (f, SCM_UNDEFINED);
|
|
||||||
return f;
|
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
|
@ -217,6 +221,7 @@ scm_is_fluid (SCM obj)
|
||||||
static SCM
|
static SCM
|
||||||
fluid_ref (SCM fluid)
|
fluid_ref (SCM fluid)
|
||||||
{
|
{
|
||||||
|
SCM ret;
|
||||||
SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
|
SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
|
||||||
|
|
||||||
if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
|
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);
|
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,
|
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}.")
|
"Unset the value associated with @var{fluid}.")
|
||||||
#define FUNC_NAME s_scm_fluid_unset_x
|
#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);
|
return scm_fluid_set_x (fluid, SCM_UNDEFINED);
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
|
||||||
|
|
@ -56,10 +56,12 @@
|
||||||
|
|
||||||
#define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid))
|
#define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid))
|
||||||
#ifdef BUILDING_LIBGUILE
|
#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
|
#endif
|
||||||
|
|
||||||
SCM_API SCM scm_make_fluid (void);
|
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 SCM scm_make_unbound_fluid (void);
|
||||||
SCM_API int scm_is_fluid (SCM obj);
|
SCM_API int scm_is_fluid (SCM obj);
|
||||||
SCM_API SCM scm_fluid_p (SCM fl);
|
SCM_API SCM scm_fluid_p (SCM fl);
|
||||||
|
|
|
||||||
|
|
@ -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")
|
"type should match @var{return-type} and @var{arg-types}.\n")
|
||||||
#define FUNC_NAME s_scm_procedure_to_pointer
|
#define FUNC_NAME s_scm_procedure_to_pointer
|
||||||
{
|
{
|
||||||
SCM pointer;
|
SCM cif_pointer, pointer;
|
||||||
ffi_cif *cif;
|
ffi_cif *cif;
|
||||||
ffi_status err;
|
ffi_status err;
|
||||||
void *closure, *executable;
|
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);
|
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)
|
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
|
else
|
||||||
{
|
{
|
||||||
/* CLOSURE needs to be freed eventually. However, since
|
/* 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);
|
pointer = scm_from_pointer (executable, NULL);
|
||||||
friend = scm_from_pointer (closure, ffi_closure_free);
|
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;
|
return pointer;
|
||||||
|
|
|
||||||
|
|
@ -88,12 +88,14 @@ scm_realloc (void *mem, size_t size)
|
||||||
{
|
{
|
||||||
void *ptr;
|
void *ptr;
|
||||||
|
|
||||||
|
scm_gc_register_allocation (size);
|
||||||
|
|
||||||
SCM_SYSCALL (ptr = realloc (mem, size));
|
SCM_SYSCALL (ptr = realloc (mem, size));
|
||||||
if (ptr)
|
if (ptr)
|
||||||
return ptr;
|
return ptr;
|
||||||
|
|
||||||
/* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */
|
/* 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));
|
SCM_SYSCALL (ptr = realloc (mem, size));
|
||||||
if (ptr)
|
if (ptr)
|
||||||
|
|
|
||||||
220
libguile/gc.c
220
libguile/gc.c
|
|
@ -27,6 +27,7 @@
|
||||||
#include <stdio.h>
|
#include <stdio.h>
|
||||||
#include <errno.h>
|
#include <errno.h>
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
|
#include <math.h>
|
||||||
|
|
||||||
#ifdef __ia64__
|
#ifdef __ia64__
|
||||||
#include <ucontext.h>
|
#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 */
|
#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. */
|
/* Hooks. */
|
||||||
scm_t_c_hook scm_before_gc_c_hook;
|
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_time_taken = 0;
|
||||||
static long gc_start_time = 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;
|
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
|
#define FUNC_NAME s_scm_gc_stats
|
||||||
{
|
{
|
||||||
SCM answer;
|
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;
|
size_t gc_times;
|
||||||
|
|
||||||
heap_size = GC_get_heap_size ();
|
GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
|
||||||
free_bytes = GC_get_free_bytes ();
|
&bytes_since_gc, &total_bytes);
|
||||||
bytes_since_gc = GC_get_bytes_since_gc ();
|
gc_times = GC_gc_no;
|
||||||
total_bytes = GC_get_total_bytes ();
|
|
||||||
gc_times = GC_gc_no;
|
|
||||||
|
|
||||||
answer =
|
answer =
|
||||||
scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
|
scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
|
||||||
|
|
@ -579,7 +607,10 @@ void
|
||||||
scm_storage_prehistory ()
|
scm_storage_prehistory ()
|
||||||
{
|
{
|
||||||
GC_all_interior_pointers = 0;
|
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 ();
|
GC_INIT ();
|
||||||
|
|
||||||
|
|
@ -723,7 +754,8 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED,
|
||||||
void *data SCM_UNUSED)
|
void *data SCM_UNUSED)
|
||||||
{
|
{
|
||||||
if (gc_start_time)
|
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_time_taken += now - gc_start_time;
|
||||||
gc_start_time = 0;
|
gc_start_time = 0;
|
||||||
}
|
}
|
||||||
|
|
@ -731,6 +763,168 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED,
|
||||||
return NULL;
|
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_before_gc_c_hook, start_gc_timer, NULL, 0);
|
||||||
scm_c_hook_add (&scm_after_gc_c_hook, accumulate_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
|
#ifdef HAVE_GC_SET_START_CALLBACK
|
||||||
GC_set_start_callback (run_before_gc_c_hook);
|
GC_set_start_callback (run_before_gc_c_hook);
|
||||||
#endif
|
#endif
|
||||||
|
|
|
||||||
|
|
@ -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_mark (SCM p);
|
||||||
SCM_API void scm_gc_sweep (void);
|
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_malloc (size_t size) SCM_MALLOC;
|
||||||
SCM_API void *scm_calloc (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);
|
SCM_API void *scm_realloc (void *mem, size_t size);
|
||||||
|
|
|
||||||
|
|
@ -1043,8 +1043,7 @@ scm_init_load ()
|
||||||
scm_loc_fresh_auto_compile
|
scm_loc_fresh_auto_compile
|
||||||
= SCM_VARIABLE_LOC (scm_c_define ("%fresh-auto-compile", SCM_BOOL_F));
|
= SCM_VARIABLE_LOC (scm_c_define ("%fresh-auto-compile", SCM_BOOL_F));
|
||||||
|
|
||||||
the_reader = scm_make_fluid ();
|
the_reader = scm_make_fluid_with_default (SCM_BOOL_F);
|
||||||
scm_fluid_set_x (the_reader, SCM_BOOL_F);
|
|
||||||
scm_c_define("current-reader", the_reader);
|
scm_c_define("current-reader", the_reader);
|
||||||
|
|
||||||
scm_c_define ("load-compiled",
|
scm_c_define ("load-compiled",
|
||||||
|
|
|
||||||
|
|
@ -292,7 +292,7 @@ memoize (SCM exp, SCM env)
|
||||||
int nreq, nopt, ntotal;
|
int nreq, nopt, ntotal;
|
||||||
|
|
||||||
req = REF (exp, LAMBDA_CASE, REQ);
|
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);
|
opt = REF (exp, LAMBDA_CASE, OPT);
|
||||||
kw = REF (exp, LAMBDA_CASE, KW);
|
kw = REF (exp, LAMBDA_CASE, KW);
|
||||||
inits = REF (exp, LAMBDA_CASE, INITS);
|
inits = REF (exp, LAMBDA_CASE, INITS);
|
||||||
|
|
|
||||||
|
|
@ -32,6 +32,7 @@
|
||||||
#include <sys/types.h>
|
#include <sys/types.h>
|
||||||
#include <assert.h>
|
#include <assert.h>
|
||||||
#include <alignof.h>
|
#include <alignof.h>
|
||||||
|
#include <byteswap.h>
|
||||||
|
|
||||||
#include <full-read.h>
|
#include <full-read.h>
|
||||||
|
|
||||||
|
|
@ -45,11 +46,55 @@
|
||||||
The length of the header must be a multiple of 8 bytes. */
|
The length of the header must be a multiple of 8 bytes. */
|
||||||
verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
|
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
|
* 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
|
static void
|
||||||
verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
|
verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
|
||||||
#define FUNC_NAME "make_objcode_from_file"
|
#define FUNC_NAME "make_objcode_from_file"
|
||||||
|
|
@ -183,7 +228,7 @@ make_objcode_from_file (int fd)
|
||||||
|
|
||||||
verify_cookie (cookie, &st, -1, NULL);
|
verify_cookie (cookie, &st, -1, NULL);
|
||||||
|
|
||||||
return scm_bytecode_to_objcode (bv);
|
return scm_bytecode_to_native_objcode (bv);
|
||||||
}
|
}
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
@ -254,12 +299,12 @@ SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
|
/* Turn BYTECODE into objcode encoded for ENDIANNESS and WORD_SIZE. */
|
||||||
(SCM bytecode),
|
static SCM
|
||||||
"")
|
bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
|
||||||
#define FUNC_NAME s_scm_bytecode_to_objcode
|
#define FUNC_NAME "bytecode->objcode"
|
||||||
{
|
{
|
||||||
size_t size;
|
size_t size, len, metalen;
|
||||||
const scm_t_uint8 *c_bytecode;
|
const scm_t_uint8 *c_bytecode;
|
||||||
struct scm_objcode *data;
|
struct scm_objcode *data;
|
||||||
|
|
||||||
|
|
@ -268,14 +313,17 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
|
||||||
|
|
||||||
size = SCM_BYTEVECTOR_LENGTH (bytecode);
|
size = SCM_BYTEVECTOR_LENGTH (bytecode);
|
||||||
c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
|
c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
|
||||||
|
|
||||||
SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
|
SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
|
||||||
data = (struct scm_objcode*)c_bytecode;
|
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_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
|
||||||
scm_list_2 (scm_from_size_t (size),
|
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
|
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
|
||||||
will be of the same length; perhaps a bad assumption? */
|
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
|
#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_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
|
||||||
(SCM file),
|
(SCM file),
|
||||||
"")
|
"")
|
||||||
|
|
@ -324,41 +393,37 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
|
||||||
"")
|
"")
|
||||||
#define FUNC_NAME s_scm_write_objcode
|
#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 cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
|
||||||
char endianness;
|
char endianness, word_size;
|
||||||
char word_size;
|
size_t total_size;
|
||||||
|
|
||||||
SCM_VALIDATE_OBJCODE (1, objcode);
|
SCM_VALIDATE_OBJCODE (1, objcode);
|
||||||
SCM_VALIDATE_OUTPUT_PORT (2, port);
|
SCM_VALIDATE_OUTPUT_PORT (2, port);
|
||||||
|
endianness = target_endianness ();
|
||||||
if (scm_is_false (target_endianness_var))
|
switch (target_word_size ())
|
||||||
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))))
|
|
||||||
{
|
{
|
||||||
case 4: word_size = '4'; break;
|
case 4:
|
||||||
case 8: word_size = '8'; break;
|
word_size = '4';
|
||||||
default: abort ();
|
break;
|
||||||
|
case 8:
|
||||||
|
word_size = '8';
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
abort ();
|
||||||
}
|
}
|
||||||
|
|
||||||
memcpy (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
|
memcpy (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
|
||||||
cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
|
cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
|
||||||
cookie[SCM_OBJCODE_WORD_SIZE_OFFSET] = word_size;
|
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, cookie, strlen (SCM_OBJCODE_COOKIE));
|
||||||
scm_c_write_unlocked (port, SCM_OBJCODE_DATA (objcode),
|
scm_c_write_unlocked (port, SCM_OBJCODE_DATA (objcode),
|
||||||
sizeof (struct scm_objcode)
|
sizeof (struct scm_objcode)
|
||||||
+ SCM_OBJCODE_TOTAL_LEN (objcode));
|
+ total_size);
|
||||||
|
|
||||||
return SCM_UNSPECIFIED;
|
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 ("word-size", scm_from_size_t (sizeof(SCM)));
|
||||||
scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
|
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");
|
||||||
}
|
}
|
||||||
|
|
||||||
/*
|
/*
|
||||||
|
|
|
||||||
|
|
@ -60,11 +60,12 @@ struct scm_objcode
|
||||||
#define SCM_OBJCODE_NATIVE_CODE(x) (SCM_CELL_WORD_3 (x))
|
#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))
|
#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_load_objcode (SCM file);
|
||||||
SCM_API SCM scm_objcode_p (SCM obj);
|
SCM_API SCM scm_objcode_p (SCM obj);
|
||||||
SCM_API SCM scm_objcode_meta (SCM objcode);
|
SCM_API SCM scm_objcode_meta (SCM objcode);
|
||||||
SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
|
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_objcode_to_bytecode (SCM objcode);
|
||||||
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
|
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2762,13 +2762,13 @@ scm_init_ports ()
|
||||||
#include "libguile/ports.x"
|
#include "libguile/ports.x"
|
||||||
|
|
||||||
/* Use Latin-1 as the default port encoding. */
|
/* Use Latin-1 as the default port encoding. */
|
||||||
SCM_VARIABLE_SET (default_port_encoding_var, scm_make_fluid ());
|
SCM_VARIABLE_SET (default_port_encoding_var,
|
||||||
scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
|
scm_make_fluid_with_default (SCM_BOOL_F));
|
||||||
scm_port_encoding_init = 1;
|
scm_port_encoding_init = 1;
|
||||||
|
|
||||||
SCM_VARIABLE_SET (scm_conversion_strategy, scm_make_fluid ());
|
SCM_VARIABLE_SET (scm_conversion_strategy,
|
||||||
scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy),
|
scm_make_fluid_with_default
|
||||||
scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK));
|
(scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK)));
|
||||||
scm_conversion_strategy_init = 1;
|
scm_conversion_strategy_init = 1;
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -43,9 +43,23 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
|
||||||
|
|
||||||
static SCM overrides;
|
static SCM overrides;
|
||||||
|
|
||||||
|
static SCM arity_overrides;
|
||||||
|
|
||||||
int
|
int
|
||||||
scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
|
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))
|
while (!SCM_PROGRAM_P (proc))
|
||||||
{
|
{
|
||||||
if (SCM_STRUCTP (proc))
|
if (SCM_STRUCTP (proc))
|
||||||
|
|
@ -63,9 +77,27 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
|
||||||
else
|
else
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
return scm_i_program_arity (proc, req, opt, rest);
|
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_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
|
||||||
(SCM proc),
|
(SCM proc),
|
||||||
"Return the \"minimum arity\" of a procedure.\n\n"
|
"Return the \"minimum arity\" of a procedure.\n\n"
|
||||||
|
|
@ -171,6 +203,7 @@ void
|
||||||
scm_init_procprop ()
|
scm_init_procprop ()
|
||||||
{
|
{
|
||||||
overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
|
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"
|
#include "libguile/procprop.x"
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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_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_minimum_arity (SCM proc);
|
||||||
SCM_API SCM scm_procedure_properties (SCM proc);
|
SCM_API SCM scm_procedure_properties (SCM proc);
|
||||||
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
|
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
|
||||||
|
|
|
||||||
|
|
@ -1740,8 +1740,7 @@ scm_init_read ()
|
||||||
{
|
{
|
||||||
SCM read_hash_procs;
|
SCM read_hash_procs;
|
||||||
|
|
||||||
read_hash_procs = scm_make_fluid ();
|
read_hash_procs = scm_make_fluid_with_default (SCM_EOL);
|
||||||
scm_fluid_set_x (read_hash_procs, SCM_EOL);
|
|
||||||
|
|
||||||
scm_i_read_hash_procedures =
|
scm_i_read_hash_procedures =
|
||||||
SCM_VARIABLE_LOC (scm_c_define ("%read-hash-procedures", read_hash_procs));
|
SCM_VARIABLE_LOC (scm_c_define ("%read-hash-procedures", read_hash_procs));
|
||||||
|
|
|
||||||
|
|
@ -477,7 +477,7 @@ static SCM scm_i_default_dynamic_state;
|
||||||
|
|
||||||
/* Run when a fluid is collected. */
|
/* Run when a fluid is collected. */
|
||||||
void
|
void
|
||||||
scm_i_reset_fluid (size_t n, SCM val)
|
scm_i_reset_fluid (size_t n)
|
||||||
{
|
{
|
||||||
scm_i_thread *t;
|
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);
|
SCM v = SCM_I_DYNAMIC_STATE_FLUIDS (t->dynamic_state);
|
||||||
|
|
||||||
if (n < SCM_SIMPLE_VECTOR_LENGTH (v))
|
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);
|
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)),
|
SCM_ASSERT (SCM_UNBNDP (handler) || scm_is_true (scm_procedure_p (handler)),
|
||||||
handler, SCM_ARG2, FUNC_NAME);
|
handler, SCM_ARG2, FUNC_NAME);
|
||||||
|
|
||||||
|
GC_collect_a_little ();
|
||||||
data.parent = scm_current_dynamic_state ();
|
data.parent = scm_current_dynamic_state ();
|
||||||
data.thunk = thunk;
|
data.thunk = thunk;
|
||||||
data.handler = handler;
|
data.handler = handler;
|
||||||
|
|
|
||||||
|
|
@ -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_without_guile (void *(*func)(void *), void *data);
|
||||||
SCM_API void *scm_with_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_threads_prehistory (void *);
|
||||||
SCM_INTERNAL void scm_init_threads (void);
|
SCM_INTERNAL void scm_init_threads (void);
|
||||||
SCM_INTERNAL void scm_init_thread_procs (void);
|
SCM_INTERNAL void scm_init_thread_procs (void);
|
||||||
|
|
|
||||||
|
|
@ -1660,6 +1660,8 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
|
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)))
|
if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
|
||||||
{
|
{
|
||||||
finish_args = *sp;
|
finish_args = *sp;
|
||||||
|
|
|
||||||
|
|
@ -393,7 +393,7 @@ really_make_boot_program (long nargs)
|
||||||
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
|
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
|
||||||
sizeof (struct scm_objcode) + sizeof (text),
|
sizeof (struct scm_objcode) + sizeof (text),
|
||||||
SCM_BOOL_F);
|
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_BOOL_F, SCM_BOOL_F);
|
||||||
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
|
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -46,62 +46,72 @@ top_builddir="@top_builddir_absolute@"
|
||||||
exit 1
|
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
|
then
|
||||||
GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline:${top_srcdir}"
|
if [ x"$GUILE_LOAD_PATH" = x ]
|
||||||
if test "${top_srcdir}" != "${top_builddir}"; then
|
then
|
||||||
GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
|
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
|
fi
|
||||||
else
|
export GUILE_LOAD_PATH
|
||||||
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
|
|
||||||
|
|
||||||
if [ x"$GUILE_LOAD_COMPILED_PATH" = x ]
|
if test "x$GUILE_LOAD_COMPILED_PATH" = "x"
|
||||||
then
|
then
|
||||||
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
|
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
|
||||||
else
|
else
|
||||||
for d in "/module" "/guile-readline" ""
|
for d in "/module" "/guile-readline" ""
|
||||||
do
|
do
|
||||||
# This hair prevents double inclusion.
|
# This hair prevents double inclusion.
|
||||||
# The ":" prevents prefix aliasing.
|
# The ":" prevents prefix aliasing.
|
||||||
case x"$GUILE_LOAD_COMPILED_PATH" in
|
case x"$GUILE_LOAD_COMPILED_PATH" in
|
||||||
x*${top_builddir}${d}:*) ;;
|
x*${top_builddir}${d}:*) ;;
|
||||||
x*${top_builddir}${d}) ;;
|
x*${top_builddir}${d}) ;;
|
||||||
*) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}:$GUILE_LOAD_COMPILED_PATH" ;;
|
*) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}:$GUILE_LOAD_COMPILED_PATH" ;;
|
||||||
esac
|
esac
|
||||||
done
|
done
|
||||||
fi
|
fi
|
||||||
export GUILE_LOAD_COMPILED_PATH
|
export GUILE_LOAD_COMPILED_PATH
|
||||||
|
|
||||||
# Don't look in installed dirs for guile modules
|
# Don't look in installed dirs for guile modules
|
||||||
if ( env | grep -v '^GUILE_SYSTEM_PATH=' > /dev/null ); then
|
if ( env | grep -v '^GUILE_SYSTEM_PATH=' > /dev/null ); then
|
||||||
GUILE_SYSTEM_PATH=
|
GUILE_SYSTEM_PATH=
|
||||||
export GUILE_SYSTEM_PATH
|
export GUILE_SYSTEM_PATH
|
||||||
fi
|
fi
|
||||||
# Don't look in installed dirs for compiled guile modules
|
# Don't look in installed dirs for compiled guile modules
|
||||||
if ( env | grep -v '^GUILE_SYSTEM_COMPILED_PATH=' > /dev/null ); then
|
if ( env | grep -v '^GUILE_SYSTEM_COMPILED_PATH=' > /dev/null ); then
|
||||||
GUILE_SYSTEM_COMPILED_PATH=
|
GUILE_SYSTEM_COMPILED_PATH=
|
||||||
export GUILE_SYSTEM_COMPILED_PATH
|
export GUILE_SYSTEM_COMPILED_PATH
|
||||||
fi
|
fi
|
||||||
# Don't look in installed dirs for dlopen-able modules
|
# Don't look in installed dirs for dlopen-able modules
|
||||||
if ( env | grep -v '^GUILE_SYSTEM_EXTENSIONS_PATH=' > /dev/null ); then
|
if ( env | grep -v '^GUILE_SYSTEM_EXTENSIONS_PATH=' > /dev/null ); then
|
||||||
GUILE_SYSTEM_EXTENSIONS_PATH=
|
GUILE_SYSTEM_EXTENSIONS_PATH=
|
||||||
export GUILE_SYSTEM_EXTENSIONS_PATH
|
export GUILE_SYSTEM_EXTENSIONS_PATH
|
||||||
|
fi
|
||||||
fi
|
fi
|
||||||
|
|
||||||
# handle LTDL_LIBRARY_PATH (no clobber)
|
# handle LTDL_LIBRARY_PATH (no clobber)
|
||||||
|
|
|
||||||
|
|
@ -79,10 +79,14 @@ ice-9/psyntax-pp.scm.gen:
|
||||||
|
|
||||||
.PHONY: 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
|
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
|
||||||
$(AM_V_GUILEC) GUILE_AUTO_COMPILE=0 \
|
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
|
||||||
$(top_builddir)/meta/uninstalled-env \
|
$(top_builddir)/meta/uninstalled-env \
|
||||||
guild compile $(GUILE_WARNINGS) -o "ice-9/psyntax-pp.go" "$(srcdir)/ice-9/psyntax.scm"
|
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 = \
|
SCHEME_LANG_SOURCES = \
|
||||||
language/scheme/spec.scm \
|
language/scheme/spec.scm \
|
||||||
|
|
|
||||||
|
|
@ -69,23 +69,6 @@
|
||||||
|
|
||||||
(define with-throw-handler #f)
|
(define with-throw-handler #f)
|
||||||
(let ()
|
(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)
|
(define (default-exception-handler k . args)
|
||||||
(cond
|
(cond
|
||||||
((eq? k 'quit)
|
((eq? k 'quit)
|
||||||
|
|
@ -98,18 +81,21 @@
|
||||||
(format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
|
(format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
|
||||||
(primitive-exit 1))))
|
(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)
|
(define (default-throw-handler prompt-tag catch-k)
|
||||||
(let ((prev (exception-handler)))
|
(let ((prev (fluid-ref %exception-handler)))
|
||||||
(lambda (thrown-k . args)
|
(lambda (thrown-k . args)
|
||||||
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
|
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
|
||||||
(apply abort-to-prompt prompt-tag thrown-k args)
|
(apply abort-to-prompt prompt-tag thrown-k args)
|
||||||
(apply prev thrown-k args)))))
|
(apply prev thrown-k args)))))
|
||||||
|
|
||||||
(define (custom-throw-handler prompt-tag catch-k pre)
|
(define (custom-throw-handler prompt-tag catch-k pre)
|
||||||
(let ((prev (exception-handler)))
|
(let ((prev (fluid-ref %exception-handler)))
|
||||||
(lambda (thrown-k . args)
|
(lambda (thrown-k . args)
|
||||||
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
|
(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)))
|
(with-fluids ((%running-exception-handlers (cons pre running)))
|
||||||
(if (not (memq pre running))
|
(if (not (memq pre running))
|
||||||
(apply pre thrown-k args))
|
(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 there is no handler at all, Guile prints an error and then exits."
|
||||||
(if (not (symbol? key))
|
(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))
|
"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.
|
;;; Reader code for various "#c" forms.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define read-eval? (make-fluid))
|
(define read-eval? (make-fluid #f))
|
||||||
(fluid-set! read-eval? #f)
|
|
||||||
(read-hash-extend #\.
|
(read-hash-extend #\.
|
||||||
(lambda (c port)
|
(lambda (c port)
|
||||||
(if (fluid-ref read-eval?)
|
(if (fluid-ref read-eval?)
|
||||||
|
|
@ -2843,14 +2828,14 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
;;; {Running Repls}
|
;;; {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
|
;; 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
|
;; script or if they are running interactively. REPL implementations ensure that
|
||||||
;; `batch-mode?' returns #f during their extent.
|
;; `batch-mode?' returns #f during their extent.
|
||||||
;;
|
;;
|
||||||
(define (batch-mode?)
|
(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
|
;; 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
|
;; `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
|
(define repl-reader
|
||||||
(lambda* (prompt #:optional (reader (fluid-ref current-reader)))
|
(lambda* (prompt #:optional (reader (fluid-ref current-reader)))
|
||||||
(if (not (char-ready?))
|
(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)
|
(force-output)
|
||||||
(run-hook before-read-hook)
|
(run-hook before-read-hook)
|
||||||
((or reader read) (current-input-port))))
|
((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))
|
(define* (make-mutable-parameter init #:optional (converter identity))
|
||||||
(let ((fluid (make-fluid)))
|
(let ((fluid (make-fluid (converter init))))
|
||||||
(fluid-set! fluid (converter init))
|
|
||||||
(case-lambda
|
(case-lambda
|
||||||
(() (fluid-ref fluid))
|
(() (fluid-ref fluid))
|
||||||
((val) (fluid-set! fluid (converter val))))))
|
((val) (fluid-set! fluid (converter val))))))
|
||||||
|
|
|
||||||
|
|
@ -235,109 +235,127 @@
|
||||||
(inits (if tail (caddr tail) '()))
|
(inits (if tail (caddr tail) '()))
|
||||||
(alt (and tail (cadddr tail))))
|
(alt (and tail (cadddr tail))))
|
||||||
(make-general-closure env body nreq rest nopt kw inits alt))))
|
(make-general-closure env body nreq rest nopt kw inits alt))))
|
||||||
(lambda %args
|
(define (set-procedure-arity! proc)
|
||||||
(let lp ((env env)
|
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
|
||||||
(nreq* nreq)
|
(if (not alt)
|
||||||
(args %args))
|
(set-procedure-minimum-arity! proc nreq nopt rest?)
|
||||||
(if (> nreq* 0)
|
(let* ((nreq* (cadr alt))
|
||||||
;; First, bind required arguments.
|
(rest?* (if (null? (cddr alt)) #f (caddr alt)))
|
||||||
(if (null? args)
|
(tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
|
||||||
(if alt
|
(nopt* (if tail (car tail) 0))
|
||||||
(apply alt-proc %args)
|
(alt* (and tail (cadddr tail))))
|
||||||
(scm-error 'wrong-number-of-args
|
(if (or (< nreq* nreq)
|
||||||
"eval" "Wrong number of arguments"
|
(and (= nreq* nreq)
|
||||||
'() #f))
|
(if rest?
|
||||||
(lp (cons (car args) env)
|
(and rest?* (> nopt* nopt))
|
||||||
(1- nreq*)
|
(or rest?* (> nopt* nopt)))))
|
||||||
(cdr args)))
|
(lp alt* nreq* nopt* rest?*)
|
||||||
;; Move on to optional arguments.
|
(lp alt* nreq nopt rest?)))))
|
||||||
(if (not kw)
|
proc)
|
||||||
;; Without keywords, bind optionals from arguments.
|
(set-procedure-arity!
|
||||||
(let lp ((env env)
|
(lambda %args
|
||||||
(nopt nopt)
|
(let lp ((env env)
|
||||||
(args args)
|
(nreq* nreq)
|
||||||
(inits inits))
|
(args %args))
|
||||||
(if (zero? nopt)
|
(if (> nreq* 0)
|
||||||
(if rest?
|
;; First, bind required arguments.
|
||||||
(eval body (cons args env))
|
(if (null? args)
|
||||||
(if (null? args)
|
(if alt
|
||||||
(eval body env)
|
(apply alt-proc %args)
|
||||||
(if alt
|
(scm-error 'wrong-number-of-args
|
||||||
(apply alt-proc %args)
|
"eval" "Wrong number of arguments"
|
||||||
(scm-error 'wrong-number-of-args
|
'() #f))
|
||||||
"eval" "Wrong number of arguments"
|
(lp (cons (car args) env)
|
||||||
'() #f))))
|
(1- nreq*)
|
||||||
(if (null? args)
|
(cdr args)))
|
||||||
(lp (cons (eval (car inits) env) env)
|
;; Move on to optional arguments.
|
||||||
(1- nopt) args (cdr inits))
|
(if (not kw)
|
||||||
(lp (cons (car args) env)
|
;; Without keywords, bind optionals from arguments.
|
||||||
(1- nopt) (cdr args) (cdr inits)))))
|
(let lp ((env env)
|
||||||
;; With keywords, we stop binding optionals at the first
|
(nopt nopt)
|
||||||
;; keyword.
|
(args args)
|
||||||
(let lp ((env env)
|
(inits inits))
|
||||||
(nopt* nopt)
|
(if (zero? nopt)
|
||||||
(args args)
|
(if rest?
|
||||||
(inits inits))
|
(eval body (cons args env))
|
||||||
(if (> nopt* 0)
|
(if (null? args)
|
||||||
(if (or (null? args) (keyword? (car args)))
|
(eval body env)
|
||||||
(lp (cons (eval (car inits) env) env)
|
(if alt
|
||||||
(1- nopt*) args (cdr inits))
|
(apply alt-proc %args)
|
||||||
(lp (cons (car args) env)
|
(scm-error 'wrong-number-of-args
|
||||||
(1- nopt*) (cdr args) (cdr inits)))
|
"eval" "Wrong number of arguments"
|
||||||
;; Finished with optionals.
|
'() #f))))
|
||||||
(let* ((aok (car kw))
|
(if (null? args)
|
||||||
(kw (cdr kw))
|
(lp (cons (eval (car inits) env) env)
|
||||||
(kw-base (+ nopt nreq (if rest? 1 0)))
|
(1- nopt) args (cdr inits))
|
||||||
(imax (let lp ((imax (1- kw-base)) (kw kw))
|
(lp (cons (car args) env)
|
||||||
(if (null? kw)
|
(1- nopt) (cdr args) (cdr inits)))))
|
||||||
imax
|
;; With keywords, we stop binding optionals at the first
|
||||||
(lp (max (cdar kw) imax)
|
;; keyword.
|
||||||
(cdr kw)))))
|
(let lp ((env env)
|
||||||
;; Fill in kwargs with "undefined" vals.
|
(nopt* nopt)
|
||||||
(env (let lp ((i kw-base)
|
(args args)
|
||||||
;; Also, here we bind the rest
|
(inits inits))
|
||||||
;; arg, if any.
|
(if (> nopt* 0)
|
||||||
(env (if rest? (cons args env) env)))
|
(if (or (null? args) (keyword? (car args)))
|
||||||
(if (<= i imax)
|
(lp (cons (eval (car inits) env) env)
|
||||||
(lp (1+ i) (cons unbound-arg env))
|
(1- nopt*) args (cdr inits))
|
||||||
env))))
|
(lp (cons (car args) env)
|
||||||
;; Now scan args for keywords.
|
(1- nopt*) (cdr args) (cdr inits)))
|
||||||
(let lp ((args args))
|
;; Finished with optionals.
|
||||||
(if (and (pair? args) (pair? (cdr args))
|
(let* ((aok (car kw))
|
||||||
(keyword? (car args)))
|
(kw (cdr kw))
|
||||||
(let ((kw-pair (assq (car args) kw))
|
(kw-base (+ nopt nreq (if rest? 1 0)))
|
||||||
(v (cadr args)))
|
(imax (let lp ((imax (1- kw-base)) (kw kw))
|
||||||
(if kw-pair
|
(if (null? kw)
|
||||||
;; Found a known keyword; set its value.
|
imax
|
||||||
(list-set! env (- imax (cdr kw-pair)) v)
|
(lp (max (cdar kw) imax)
|
||||||
;; Unknown keyword.
|
(cdr kw)))))
|
||||||
(if (not aok)
|
;; Fill in kwargs with "undefined" vals.
|
||||||
(scm-error 'keyword-argument-error
|
(env (let lp ((i kw-base)
|
||||||
"eval" "Unrecognized keyword"
|
;; Also, here we bind the rest
|
||||||
'() #f)))
|
;; arg, if any.
|
||||||
(lp (cddr args)))
|
(env (if rest? (cons args env) env)))
|
||||||
(if (pair? args)
|
(if (<= i imax)
|
||||||
(if rest?
|
(lp (1+ i) (cons unbound-arg env))
|
||||||
;; Be lenient parsing rest args.
|
env))))
|
||||||
(lp (cdr args))
|
;; Now scan args for keywords.
|
||||||
(scm-error 'keyword-argument-error
|
(let lp ((args args))
|
||||||
"eval" "Invalid keyword"
|
(if (and (pair? args) (pair? (cdr args))
|
||||||
'() #f))
|
(keyword? (car args)))
|
||||||
;; Finished parsing keywords. Fill in
|
(let ((kw-pair (assq (car args) kw))
|
||||||
;; uninitialized kwargs by evalling init
|
(v (cadr args)))
|
||||||
;; expressions in their appropriate
|
(if kw-pair
|
||||||
;; environment.
|
;; Found a known keyword; set its value.
|
||||||
(let lp ((i (- imax kw-base))
|
(list-set! env (- imax (cdr kw-pair)) v)
|
||||||
(inits inits))
|
;; Unknown keyword.
|
||||||
(if (pair? inits)
|
(if (not aok)
|
||||||
(let ((tail (list-tail env i)))
|
(scm-error 'keyword-argument-error
|
||||||
(if (eq? (car tail) unbound-arg)
|
"eval" "Unrecognized keyword"
|
||||||
(set-car! tail
|
'() #f)))
|
||||||
(eval (car inits)
|
(lp (cddr args)))
|
||||||
(cdr tail))))
|
(if (pair? args)
|
||||||
(lp (1- i) (cdr inits)))
|
(if rest?
|
||||||
;; Finally, eval the body.
|
;; Be lenient parsing rest args.
|
||||||
(eval body env))))))))))))))
|
(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.
|
;; The "engine". EXP is a memoized expression.
|
||||||
(define (eval exp env)
|
(define (eval exp env)
|
||||||
|
|
@ -404,7 +422,10 @@
|
||||||
(memoize-variable-access! exp #f))))
|
(memoize-variable-access! exp #f))))
|
||||||
|
|
||||||
(('define (name . x))
|
(('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))
|
(('toplevel-set! (var-or-sym . x))
|
||||||
(variable-set!
|
(variable-set!
|
||||||
|
|
|
||||||
|
|
@ -164,9 +164,9 @@
|
||||||
#:use-module (ice-9 optargs)
|
#:use-module (ice-9 optargs)
|
||||||
#:export (getopt-long option-ref))
|
#:export (getopt-long option-ref))
|
||||||
|
|
||||||
(define %program-name (make-fluid))
|
(define %program-name (make-fluid "guile"))
|
||||||
(define (program-name)
|
(define (program-name)
|
||||||
(or (fluid-ref %program-name) "guile"))
|
(fluid-ref %program-name))
|
||||||
|
|
||||||
(define (fatal-error fmt . args)
|
(define (fatal-error fmt . args)
|
||||||
(format (current-error-port) "~a: " (program-name))
|
(format (current-error-port) "~a: " (program-name))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load diff
|
|
@ -952,17 +952,17 @@
|
||||||
|
|
||||||
;; expanding
|
;; expanding
|
||||||
|
|
||||||
(define chi-sequence
|
(define expand-sequence
|
||||||
(lambda (body r w s mod)
|
(lambda (body r w s mod)
|
||||||
(build-sequence s
|
(build-sequence s
|
||||||
(let dobody ((body body) (r r) (w w) (mod mod))
|
(let dobody ((body body) (r r) (w w) (mod mod))
|
||||||
(if (null? body)
|
(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))))))))
|
(cons first (dobody (cdr body) r w mod))))))))
|
||||||
|
|
||||||
;; At top-level, we allow mixed definitions and expressions. Like
|
;; 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
|
;; First, from left to right, we expand just enough to know what
|
||||||
;; expressions are definitions, syntax definitions, and splicing
|
;; expressions are definitions, syntax definitions, and splicing
|
||||||
|
|
@ -975,7 +975,7 @@
|
||||||
;; expansions of all normal definitions and expressions in the
|
;; expansions of all normal definitions and expressions in the
|
||||||
;; sequence.
|
;; sequence.
|
||||||
;;
|
;;
|
||||||
(define chi-top-sequence
|
(define expand-top-sequence
|
||||||
(lambda (body r w s m esew mod)
|
(lambda (body r w s m esew mod)
|
||||||
(let* ((r (cons '("placeholder" . (placeholder)) r))
|
(let* ((r (cons '("placeholder" . (placeholder)) r))
|
||||||
(ribcage (make-empty-ribcage))
|
(ribcage (make-empty-ribcage))
|
||||||
|
|
@ -1027,11 +1027,11 @@
|
||||||
(record-definition! id var)
|
(record-definition! id var)
|
||||||
(list
|
(list
|
||||||
(if (eq? m 'c&e)
|
(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)
|
(top-level-eval-hook x mod)
|
||||||
(lambda () x))
|
(lambda () x))
|
||||||
(lambda ()
|
(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)
|
((define-syntax-form define-syntax-parameter-form)
|
||||||
(let* ((id (wrap value w mod))
|
(let* ((id (wrap value w mod))
|
||||||
(label (gen-label))
|
(label (gen-label))
|
||||||
|
|
@ -1043,23 +1043,23 @@
|
||||||
((c)
|
((c)
|
||||||
(cond
|
(cond
|
||||||
((memq 'compile esew)
|
((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)
|
(top-level-eval-hook e mod)
|
||||||
(if (memq 'load esew)
|
(if (memq 'load esew)
|
||||||
(list (lambda () e))
|
(list (lambda () e))
|
||||||
'())))
|
'())))
|
||||||
((memq 'load esew)
|
((memq 'load esew)
|
||||||
(list (lambda ()
|
(list (lambda ()
|
||||||
(chi-install-global var type (chi e r w mod)))))
|
(expand-install-global var type (expand e r w mod)))))
|
||||||
(else '())))
|
(else '())))
|
||||||
((c&e)
|
((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)
|
(top-level-eval-hook e mod)
|
||||||
(list (lambda () e))))
|
(list (lambda () e))))
|
||||||
(else
|
(else
|
||||||
(if (memq 'eval esew)
|
(if (memq 'eval esew)
|
||||||
(top-level-eval-hook
|
(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))
|
mod))
|
||||||
'()))))
|
'()))))
|
||||||
((begin-form)
|
((begin-form)
|
||||||
|
|
@ -1067,13 +1067,13 @@
|
||||||
((_ e1 ...)
|
((_ e1 ...)
|
||||||
(parse #'(e1 ...) r w s m esew mod))))
|
(parse #'(e1 ...) r w s m esew mod))))
|
||||||
((local-syntax-form)
|
((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)
|
(lambda (forms r w s mod)
|
||||||
(parse forms r w s m esew mod))))
|
(parse forms r w s m esew mod))))
|
||||||
((eval-when-form)
|
((eval-when-form)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ (x ...) e1 e2 ...)
|
((_ (x ...) e1 e2 ...)
|
||||||
(let ((when-list (chi-when-list e #'(x ...) w))
|
(let ((when-list (parse-when-list e #'(x ...)))
|
||||||
(body #'(e1 e2 ...)))
|
(body #'(e1 e2 ...)))
|
||||||
(define (recurse m esew)
|
(define (recurse m esew)
|
||||||
(parse body r w s m esew mod))
|
(parse body r w s m esew mod))
|
||||||
|
|
@ -1085,7 +1085,7 @@
|
||||||
(begin
|
(begin
|
||||||
(if (memq 'expand when-list)
|
(if (memq 'expand when-list)
|
||||||
(top-level-eval-hook
|
(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))
|
mod))
|
||||||
'())))
|
'())))
|
||||||
((memq 'load when-list)
|
((memq 'load when-list)
|
||||||
|
|
@ -1100,7 +1100,7 @@
|
||||||
(memq 'expand when-list)
|
(memq 'expand when-list)
|
||||||
(and (eq? m 'c&e) (memq 'eval when-list)))
|
(and (eq? m 'c&e) (memq 'eval when-list)))
|
||||||
(top-level-eval-hook
|
(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)
|
mod)
|
||||||
'())
|
'())
|
||||||
(else
|
(else
|
||||||
|
|
@ -1108,18 +1108,18 @@
|
||||||
(else
|
(else
|
||||||
(list
|
(list
|
||||||
(if (eq? m 'c&e)
|
(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)
|
(top-level-eval-hook x mod)
|
||||||
(lambda () x))
|
(lambda () x))
|
||||||
(lambda ()
|
(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))
|
(let ((exps (map (lambda (x) (x))
|
||||||
(reverse (parse body r w s m esew mod)))))
|
(reverse (parse body r w s m esew mod)))))
|
||||||
(if (null? exps)
|
(if (null? exps)
|
||||||
(build-void s)
|
(build-void s)
|
||||||
(build-sequence s exps))))))
|
(build-sequence s exps))))))
|
||||||
|
|
||||||
(define chi-install-global
|
(define expand-install-global
|
||||||
(lambda (name type e)
|
(lambda (name type e)
|
||||||
(build-global-definition
|
(build-global-definition
|
||||||
no-source
|
no-source
|
||||||
|
|
@ -1135,24 +1135,21 @@
|
||||||
(build-data no-source 'macro)
|
(build-data no-source 'macro)
|
||||||
e))))))
|
e))))))
|
||||||
|
|
||||||
(define chi-when-list
|
(define parse-when-list
|
||||||
(lambda (e when-list w)
|
(lambda (e when-list)
|
||||||
;; `when-list' is syntax'd version of list of situations. We
|
;; `when-list' is syntax'd version of list of situations. We
|
||||||
;; could match these keywords lexically, via free-id=?, but then
|
;; could match these keywords lexically, via free-id=?, but then
|
||||||
;; we twingle the definition of eval-when to the bindings of
|
;; we twingle the definition of eval-when to the bindings of
|
||||||
;; eval, load, expand, and compile, which is totally unintended.
|
;; eval, load, expand, and compile, which is totally unintended.
|
||||||
;; So do a symbolic match instead.
|
;; So do a symbolic match instead.
|
||||||
(let f ((when-list when-list) (situations '()))
|
(let ((result (strip when-list empty-wrap)))
|
||||||
(if (null? when-list)
|
(let lp ((l result))
|
||||||
situations
|
(if (null? l)
|
||||||
(f (cdr when-list)
|
result
|
||||||
(cons (let ((x (syntax->datum (car when-list))))
|
(if (memq (car l) '(compile load eval expand))
|
||||||
(if (memq x '(compile load eval expand))
|
(lp (cdr l))
|
||||||
x
|
(syntax-violation 'eval-when "invalid situation" e
|
||||||
(syntax-violation 'eval-when
|
(car l))))))))
|
||||||
"invalid situation"
|
|
||||||
e (wrap (car when-list) w #f))))
|
|
||||||
situations))))))
|
|
||||||
|
|
||||||
;; syntax-type returns six values: type, value, e, w, s, and mod. The
|
;; syntax-type returns six values: type, value, e, w, s, and mod. The
|
||||||
;; first two are described in the table below.
|
;; first two are described in the table below.
|
||||||
|
|
@ -1203,7 +1200,7 @@
|
||||||
((macro)
|
((macro)
|
||||||
(if for-car?
|
(if for-car?
|
||||||
(values type value e w s mod)
|
(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)))
|
r empty-wrap s rib mod #f)))
|
||||||
((global)
|
((global)
|
||||||
;; Toplevel definitions may resolve to bindings with
|
;; Toplevel definitions may resolve to bindings with
|
||||||
|
|
@ -1225,7 +1222,7 @@
|
||||||
(values 'global-call (make-syntax-object fval w fmod)
|
(values 'global-call (make-syntax-object fval w fmod)
|
||||||
e w s mod))
|
e w s mod))
|
||||||
((macro)
|
((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?))
|
r empty-wrap s rib mod for-car?))
|
||||||
((module-ref)
|
((module-ref)
|
||||||
(call-with-values (lambda () (fval e r w))
|
(call-with-values (lambda () (fval e r w))
|
||||||
|
|
@ -1279,14 +1276,14 @@
|
||||||
((self-evaluating? e) (values 'constant #f e w s mod))
|
((self-evaluating? e) (values 'constant #f e w s mod))
|
||||||
(else (values 'other #f e w s mod)))))
|
(else (values 'other #f e w s mod)))))
|
||||||
|
|
||||||
(define chi
|
(define expand
|
||||||
(lambda (e r w mod)
|
(lambda (e r w mod)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
|
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
|
||||||
(lambda (type value e w s mod)
|
(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)
|
(lambda (type value e r w s mod)
|
||||||
(case type
|
(case type
|
||||||
((lexical)
|
((lexical)
|
||||||
|
|
@ -1297,9 +1294,9 @@
|
||||||
((module-ref)
|
((module-ref)
|
||||||
(call-with-values (lambda () (value e r w))
|
(call-with-values (lambda () (value e r w))
|
||||||
(lambda (e r w s mod)
|
(lambda (e r w s mod)
|
||||||
(chi e r w mod))))
|
(expand e r w mod))))
|
||||||
((lexical-call)
|
((lexical-call)
|
||||||
(chi-call
|
(expand-call
|
||||||
(let ((id (car e)))
|
(let ((id (car e)))
|
||||||
(build-lexical-reference 'fun (source-annotation id)
|
(build-lexical-reference 'fun (source-annotation id)
|
||||||
(if (syntax-object? id)
|
(if (syntax-object? id)
|
||||||
|
|
@ -1308,7 +1305,7 @@
|
||||||
value))
|
value))
|
||||||
e r w s mod))
|
e r w s mod))
|
||||||
((global-call)
|
((global-call)
|
||||||
(chi-call
|
(expand-call
|
||||||
(build-global-reference (source-annotation (car e))
|
(build-global-reference (source-annotation (car e))
|
||||||
(if (syntax-object? value)
|
(if (syntax-object? value)
|
||||||
(syntax-object-expression value)
|
(syntax-object-expression value)
|
||||||
|
|
@ -1319,19 +1316,19 @@
|
||||||
e r w s mod))
|
e r w s mod))
|
||||||
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
|
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
|
||||||
((global) (build-global-reference s value mod))
|
((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)
|
((begin-form)
|
||||||
(syntax-case e ()
|
(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)
|
((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)
|
((eval-when-form)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ (x ...) e1 e2 ...)
|
((_ (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)
|
(if (memq 'eval when-list)
|
||||||
(chi-sequence #'(e1 e2 ...) r w s mod)
|
(expand-sequence #'(e1 e2 ...) r w s mod)
|
||||||
(chi-void))))))
|
(expand-void))))))
|
||||||
((define-form define-syntax-form define-syntax-parameter-form)
|
((define-form define-syntax-form define-syntax-parameter-form)
|
||||||
(syntax-violation #f "definition in expression context"
|
(syntax-violation #f "definition in expression context"
|
||||||
e (wrap value w mod)))
|
e (wrap value w mod)))
|
||||||
|
|
@ -1344,12 +1341,12 @@
|
||||||
(else (syntax-violation #f "unexpected syntax"
|
(else (syntax-violation #f "unexpected syntax"
|
||||||
(source-wrap e w s mod))))))
|
(source-wrap e w s mod))))))
|
||||||
|
|
||||||
(define chi-call
|
(define expand-call
|
||||||
(lambda (x e r w s mod)
|
(lambda (x e r w s mod)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((e0 e1 ...)
|
((e0 e1 ...)
|
||||||
(build-call s x
|
(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)
|
;; (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
|
;; really nice if we could also annotate introduced expressions with the
|
||||||
;; locations corresponding to the macro definition, but that is not yet
|
;; locations corresponding to the macro definition, but that is not yet
|
||||||
;; possible.
|
;; possible.
|
||||||
(define chi-macro
|
(define expand-macro
|
||||||
(lambda (p e r w s rib mod)
|
(lambda (p e r w s rib mod)
|
||||||
(define rebuild-macro-output
|
(define rebuild-macro-output
|
||||||
(lambda (x m)
|
(lambda (x m)
|
||||||
|
|
@ -1425,7 +1422,7 @@
|
||||||
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
|
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
|
||||||
(new-mark))))
|
(new-mark))))
|
||||||
|
|
||||||
(define chi-body
|
(define expand-body
|
||||||
;; In processing the forms of the body, we create a new, empty wrap.
|
;; In processing the forms of the body, we create a new, empty wrap.
|
||||||
;; This wrap is augmented (destructively) each time we discover that
|
;; This wrap is augmented (destructively) each time we discover that
|
||||||
;; the next form is a definition. This is done:
|
;; the next form is a definition. This is done:
|
||||||
|
|
@ -1509,19 +1506,19 @@
|
||||||
(f (cdr forms)))))
|
(f (cdr forms)))))
|
||||||
ids labels var-ids vars vals bindings))))
|
ids labels var-ids vars vals bindings))))
|
||||||
((local-syntax-form)
|
((local-syntax-form)
|
||||||
(chi-local-syntax value e er w s mod
|
(expand-local-syntax value e er w s mod
|
||||||
(lambda (forms er w s mod)
|
(lambda (forms er w s mod)
|
||||||
(parse (let f ((forms forms))
|
(parse (let f ((forms forms))
|
||||||
(if (null? forms)
|
(if (null? forms)
|
||||||
(cdr body)
|
(cdr body)
|
||||||
(cons (cons er (wrap (car forms) w mod))
|
(cons (cons er (wrap (car forms) w mod))
|
||||||
(f (cdr forms)))))
|
(f (cdr forms)))))
|
||||||
ids labels var-ids vars vals bindings))))
|
ids labels var-ids vars vals bindings))))
|
||||||
(else ; found a non-definition
|
(else ; found a non-definition
|
||||||
(if (null? ids)
|
(if (null? ids)
|
||||||
(build-sequence no-source
|
(build-sequence no-source
|
||||||
(map (lambda (x)
|
(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))
|
(cons (cons er (source-wrap e w s mod))
|
||||||
(cdr body))))
|
(cdr body))))
|
||||||
(begin
|
(begin
|
||||||
|
|
@ -1540,7 +1537,7 @@
|
||||||
(macros-only-env er))))
|
(macros-only-env er))))
|
||||||
(set-cdr! b
|
(set-cdr! b
|
||||||
(eval-local-transformer
|
(eval-local-transformer
|
||||||
(chi (cddr b) r-cache empty-wrap mod)
|
(expand (cddr b) r-cache empty-wrap mod)
|
||||||
mod))
|
mod))
|
||||||
(if (eq? (car b) 'syntax-parameter)
|
(if (eq? (car b) 'syntax-parameter)
|
||||||
(set-cdr! b (list (cdr b))))
|
(set-cdr! b (list (cdr b))))
|
||||||
|
|
@ -1551,15 +1548,15 @@
|
||||||
(reverse (map syntax->datum var-ids))
|
(reverse (map syntax->datum var-ids))
|
||||||
(reverse vars)
|
(reverse vars)
|
||||||
(map (lambda (x)
|
(map (lambda (x)
|
||||||
(chi (cdr x) (car x) empty-wrap mod))
|
(expand (cdr x) (car x) empty-wrap mod))
|
||||||
(reverse vals))
|
(reverse vals))
|
||||||
(build-sequence no-source
|
(build-sequence no-source
|
||||||
(map (lambda (x)
|
(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))
|
(cons (cons er (source-wrap e w s mod))
|
||||||
(cdr body)))))))))))))))))
|
(cdr body)))))))))))))))))
|
||||||
|
|
||||||
(define chi-local-syntax
|
(define expand-local-syntax
|
||||||
(lambda (rec? e r w s mod k)
|
(lambda (rec? e r w s mod k)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ ((id val) ...) e1 e2 ...)
|
((_ ((id val) ...) e1 e2 ...)
|
||||||
|
|
@ -1576,7 +1573,7 @@
|
||||||
(map (lambda (x)
|
(map (lambda (x)
|
||||||
(make-binding 'macro
|
(make-binding 'macro
|
||||||
(eval-local-transformer
|
(eval-local-transformer
|
||||||
(chi x trans-r w mod)
|
(expand x trans-r w mod)
|
||||||
mod)))
|
mod)))
|
||||||
#'(val ...)))
|
#'(val ...)))
|
||||||
r)
|
r)
|
||||||
|
|
@ -1593,7 +1590,7 @@
|
||||||
p
|
p
|
||||||
(syntax-violation #f "nonprocedure transformer" p)))))
|
(syntax-violation #f "nonprocedure transformer" p)))))
|
||||||
|
|
||||||
(define chi-void
|
(define expand-void
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(build-void no-source)))
|
(build-void no-source)))
|
||||||
|
|
||||||
|
|
@ -1623,7 +1620,7 @@
|
||||||
orig-args))))
|
orig-args))))
|
||||||
(req orig-args '())))
|
(req orig-args '())))
|
||||||
|
|
||||||
(define chi-simple-lambda
|
(define expand-simple-lambda
|
||||||
(lambda (e r w s mod req rest meta body)
|
(lambda (e r w s mod req rest meta body)
|
||||||
(let* ((ids (if rest (append req (list rest)) req))
|
(let* ((ids (if rest (append req (list rest)) req))
|
||||||
(vars (map gen-var ids))
|
(vars (map gen-var ids))
|
||||||
|
|
@ -1632,10 +1629,10 @@
|
||||||
s
|
s
|
||||||
(map syntax->datum req) (and rest (syntax->datum rest)) vars
|
(map syntax->datum req) (and rest (syntax->datum rest)) vars
|
||||||
meta
|
meta
|
||||||
(chi-body body (source-wrap e w s mod)
|
(expand-body body (source-wrap e w s mod)
|
||||||
(extend-var-env labels vars r)
|
(extend-var-env labels vars r)
|
||||||
(make-binding-wrap ids labels w)
|
(make-binding-wrap ids labels w)
|
||||||
mod)))))
|
mod)))))
|
||||||
|
|
||||||
(define lambda*-formals
|
(define lambda*-formals
|
||||||
(lambda (orig-args)
|
(lambda (orig-args)
|
||||||
|
|
@ -1718,16 +1715,16 @@
|
||||||
orig-args))))
|
orig-args))))
|
||||||
(req orig-args '())))
|
(req orig-args '())))
|
||||||
|
|
||||||
(define chi-lambda-case
|
(define expand-lambda-case
|
||||||
(lambda (e r w s mod get-formals clauses)
|
(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))
|
(let ((vars (map gen-var req))
|
||||||
(labels (gen-labels req)))
|
(labels (gen-labels req)))
|
||||||
(let ((r* (extend-var-env labels vars r))
|
(let ((r* (extend-var-env labels vars r))
|
||||||
(w* (make-binding-wrap req labels w)))
|
(w* (make-binding-wrap req labels w)))
|
||||||
(expand-opt (map syntax->datum req)
|
(parse-opt (map syntax->datum req)
|
||||||
opt rest kw body (reverse vars) r* w* '() '()))))
|
opt rest kw body (reverse vars) r* w* '() '()))))
|
||||||
(define (expand-opt req opt rest kw body vars r* w* out inits)
|
(define (parse-opt req opt rest kw body vars r* w* out inits)
|
||||||
(cond
|
(cond
|
||||||
((pair? opt)
|
((pair? opt)
|
||||||
(syntax-case (car opt) ()
|
(syntax-case (car opt) ()
|
||||||
|
|
@ -1736,27 +1733,27 @@
|
||||||
(l (gen-labels (list v)))
|
(l (gen-labels (list v)))
|
||||||
(r** (extend-var-env l (list v) r*))
|
(r** (extend-var-env l (list v) r*))
|
||||||
(w** (make-binding-wrap (list #'id) l w*)))
|
(w** (make-binding-wrap (list #'id) l w*)))
|
||||||
(expand-opt req (cdr opt) rest kw body (cons v vars)
|
(parse-opt req (cdr opt) rest kw body (cons v vars)
|
||||||
r** w** (cons (syntax->datum #'id) out)
|
r** w** (cons (syntax->datum #'id) out)
|
||||||
(cons (chi #'i r* w* mod) inits))))))
|
(cons (expand #'i r* w* mod) inits))))))
|
||||||
(rest
|
(rest
|
||||||
(let* ((v (gen-var rest))
|
(let* ((v (gen-var rest))
|
||||||
(l (gen-labels (list v)))
|
(l (gen-labels (list v)))
|
||||||
(r* (extend-var-env l (list v) r*))
|
(r* (extend-var-env l (list v) r*))
|
||||||
(w* (make-binding-wrap (list rest) l w*)))
|
(w* (make-binding-wrap (list rest) l w*)))
|
||||||
(expand-kw req (if (pair? out) (reverse out) #f)
|
(parse-kw req (if (pair? out) (reverse out) #f)
|
||||||
(syntax->datum rest)
|
(syntax->datum rest)
|
||||||
(if (pair? kw) (cdr kw) kw)
|
(if (pair? kw) (cdr kw) kw)
|
||||||
body (cons v vars) r* w*
|
body (cons v vars) r* w*
|
||||||
(if (pair? kw) (car kw) #f)
|
(if (pair? kw) (car kw) #f)
|
||||||
'() inits)))
|
'() inits)))
|
||||||
(else
|
(else
|
||||||
(expand-kw req (if (pair? out) (reverse out) #f) #f
|
(parse-kw req (if (pair? out) (reverse out) #f) #f
|
||||||
(if (pair? kw) (cdr kw) kw)
|
(if (pair? kw) (cdr kw) kw)
|
||||||
body vars r* w*
|
body vars r* w*
|
||||||
(if (pair? kw) (car kw) #f)
|
(if (pair? kw) (car kw) #f)
|
||||||
'() inits))))
|
'() inits))))
|
||||||
(define (expand-kw req opt rest kw body vars r* w* aok out inits)
|
(define (parse-kw req opt rest kw body vars r* w* aok out inits)
|
||||||
(cond
|
(cond
|
||||||
((pair? kw)
|
((pair? kw)
|
||||||
(syntax-case (car kw) ()
|
(syntax-case (car kw) ()
|
||||||
|
|
@ -1765,31 +1762,31 @@
|
||||||
(l (gen-labels (list v)))
|
(l (gen-labels (list v)))
|
||||||
(r** (extend-var-env l (list v) r*))
|
(r** (extend-var-env l (list v) r*))
|
||||||
(w** (make-binding-wrap (list #'id) l w*)))
|
(w** (make-binding-wrap (list #'id) l w*)))
|
||||||
(expand-kw req opt rest (cdr kw) body (cons v vars)
|
(parse-kw req opt rest (cdr kw) body (cons v vars)
|
||||||
r** w** aok
|
r** w** aok
|
||||||
(cons (list (syntax->datum #'k)
|
(cons (list (syntax->datum #'k)
|
||||||
(syntax->datum #'id)
|
(syntax->datum #'id)
|
||||||
v)
|
v)
|
||||||
out)
|
out)
|
||||||
(cons (chi #'i r* w* mod) inits))))))
|
(cons (expand #'i r* w* mod) inits))))))
|
||||||
(else
|
(else
|
||||||
(expand-body req opt rest
|
(parse-body req opt rest
|
||||||
(if (or aok (pair? out)) (cons aok (reverse out)) #f)
|
(if (or aok (pair? out)) (cons aok (reverse out)) #f)
|
||||||
body (reverse vars) r* w* (reverse inits) '()))))
|
body (reverse vars) r* w* (reverse inits) '()))))
|
||||||
(define (expand-body req opt rest kw body vars r* w* inits meta)
|
(define (parse-body req opt rest kw body vars r* w* inits meta)
|
||||||
(syntax-case body ()
|
(syntax-case body ()
|
||||||
((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
|
((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
|
||||||
(expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
|
(parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
|
||||||
(append meta
|
(append meta
|
||||||
`((documentation
|
`((documentation
|
||||||
. ,(syntax->datum #'docstring))))))
|
. ,(syntax->datum #'docstring))))))
|
||||||
((#((k . v) ...) e1 e2 ...)
|
((#((k . v) ...) e1 e2 ...)
|
||||||
(expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
|
(parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
|
||||||
(append meta (syntax->datum #'((k . v) ...)))))
|
(append meta (syntax->datum #'((k . v) ...)))))
|
||||||
((e1 e2 ...)
|
((e1 e2 ...)
|
||||||
(values meta req opt rest kw inits vars
|
(values meta req opt rest kw inits vars
|
||||||
(chi-body #'(e1 e2 ...) (source-wrap e w s mod)
|
(expand-body #'(e1 e2 ...) (source-wrap e w s mod)
|
||||||
r* w* mod)))))
|
r* w* mod)))))
|
||||||
|
|
||||||
(syntax-case clauses ()
|
(syntax-case clauses ()
|
||||||
(() (values '() #f))
|
(() (values '() #f))
|
||||||
|
|
@ -1797,12 +1794,12 @@
|
||||||
(call-with-values (lambda () (get-formals #'args))
|
(call-with-values (lambda () (get-formals #'args))
|
||||||
(lambda (req opt rest kw)
|
(lambda (req opt rest kw)
|
||||||
(call-with-values (lambda ()
|
(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)
|
(lambda (meta req opt rest kw inits vars body)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(chi-lambda-case e r w s mod get-formals
|
(expand-lambda-case e r w s mod get-formals
|
||||||
#'((args* e1* e2* ...) ...)))
|
#'((args* e1* e2* ...) ...)))
|
||||||
(lambda (meta* else*)
|
(lambda (meta* else*)
|
||||||
(values
|
(values
|
||||||
(append meta meta*)
|
(append meta meta*)
|
||||||
|
|
@ -1900,9 +1897,9 @@
|
||||||
(map (lambda (x)
|
(map (lambda (x)
|
||||||
(make-binding
|
(make-binding
|
||||||
'macro
|
'macro
|
||||||
(eval-local-transformer (chi x trans-r w mod) mod)))
|
(eval-local-transformer (expand x trans-r w mod) mod)))
|
||||||
#'(val ...)))))
|
#'(val ...)))))
|
||||||
(chi-body #'(e1 e2 ...)
|
(expand-body #'(e1 e2 ...)
|
||||||
(source-wrap e w s mod)
|
(source-wrap e w s mod)
|
||||||
(extend-env names bindings r)
|
(extend-env names bindings r)
|
||||||
w
|
w
|
||||||
|
|
@ -2094,7 +2091,7 @@
|
||||||
((#((k . v) ...) e1 e2 ...)
|
((#((k . v) ...) e1 e2 ...)
|
||||||
(lp #'(e1 e2 ...)
|
(lp #'(e1 e2 ...)
|
||||||
(append meta (syntax->datum #'((k . v) ...)))))
|
(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)))))
|
(_ (syntax-violation 'lambda "bad lambda" e)))))
|
||||||
|
|
||||||
(global-extend 'core 'lambda*
|
(global-extend 'core 'lambda*
|
||||||
|
|
@ -2103,8 +2100,8 @@
|
||||||
((_ args e1 e2 ...)
|
((_ args e1 e2 ...)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(chi-lambda-case e r w s mod
|
(expand-lambda-case e r w s mod
|
||||||
lambda*-formals #'((args e1 e2 ...))))
|
lambda*-formals #'((args e1 e2 ...))))
|
||||||
(lambda (meta lcase)
|
(lambda (meta lcase)
|
||||||
(build-case-lambda s meta lcase))))
|
(build-case-lambda s meta lcase))))
|
||||||
(_ (syntax-violation 'lambda "bad lambda*" e)))))
|
(_ (syntax-violation 'lambda "bad lambda*" e)))))
|
||||||
|
|
@ -2115,9 +2112,9 @@
|
||||||
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
|
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(chi-lambda-case e r w s mod
|
(expand-lambda-case e r w s mod
|
||||||
lambda-formals
|
lambda-formals
|
||||||
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
|
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
|
||||||
(lambda (meta lcase)
|
(lambda (meta lcase)
|
||||||
(build-case-lambda s meta lcase))))
|
(build-case-lambda s meta lcase))))
|
||||||
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
|
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
|
||||||
|
|
@ -2128,16 +2125,16 @@
|
||||||
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
|
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(chi-lambda-case e r w s mod
|
(expand-lambda-case e r w s mod
|
||||||
lambda*-formals
|
lambda*-formals
|
||||||
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
|
#'((args e1 e2 ...) (args* e1* e2* ...) ...)))
|
||||||
(lambda (meta lcase)
|
(lambda (meta lcase)
|
||||||
(build-case-lambda s meta lcase))))
|
(build-case-lambda s meta lcase))))
|
||||||
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
|
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
|
||||||
|
|
||||||
(global-extend 'core 'let
|
(global-extend 'core 'let
|
||||||
(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))
|
(if (not (valid-bound-ids? ids))
|
||||||
(syntax-violation 'let "duplicate bound variable" e)
|
(syntax-violation 'let "duplicate bound variable" e)
|
||||||
(let ((labels (gen-labels ids))
|
(let ((labels (gen-labels ids))
|
||||||
|
|
@ -2147,25 +2144,25 @@
|
||||||
(constructor s
|
(constructor s
|
||||||
(map syntax->datum ids)
|
(map syntax->datum ids)
|
||||||
new-vars
|
new-vars
|
||||||
(map (lambda (x) (chi x r w mod)) vals)
|
(map (lambda (x) (expand x r w mod)) vals)
|
||||||
(chi-body exps (source-wrap e nw s mod)
|
(expand-body exps (source-wrap e nw s mod)
|
||||||
nr nw mod))))))
|
nr nw mod))))))
|
||||||
(lambda (e r w s mod)
|
(lambda (e r w s mod)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ ((id val) ...) e1 e2 ...)
|
((_ ((id val) ...) e1 e2 ...)
|
||||||
(and-map id? #'(id ...))
|
(and-map id? #'(id ...))
|
||||||
(chi-let e r w s mod
|
(expand-let e r w s mod
|
||||||
build-let
|
build-let
|
||||||
#'(id ...)
|
#'(id ...)
|
||||||
#'(val ...)
|
#'(val ...)
|
||||||
#'(e1 e2 ...)))
|
#'(e1 e2 ...)))
|
||||||
((_ f ((id val) ...) e1 e2 ...)
|
((_ f ((id val) ...) e1 e2 ...)
|
||||||
(and (id? #'f) (and-map id? #'(id ...)))
|
(and (id? #'f) (and-map id? #'(id ...)))
|
||||||
(chi-let e r w s mod
|
(expand-let e r w s mod
|
||||||
build-named-let
|
build-named-let
|
||||||
#'(f id ...)
|
#'(f id ...)
|
||||||
#'(val ...)
|
#'(val ...)
|
||||||
#'(e1 e2 ...)))
|
#'(e1 e2 ...)))
|
||||||
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
|
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -2184,9 +2181,9 @@
|
||||||
(build-letrec s #f
|
(build-letrec s #f
|
||||||
(map syntax->datum ids)
|
(map syntax->datum ids)
|
||||||
new-vars
|
new-vars
|
||||||
(map (lambda (x) (chi x r w mod)) #'(val ...))
|
(map (lambda (x) (expand x r w mod)) #'(val ...))
|
||||||
(chi-body #'(e1 e2 ...)
|
(expand-body #'(e1 e2 ...)
|
||||||
(source-wrap e w s mod) r w mod)))))))
|
(source-wrap e w s mod) r w mod)))))))
|
||||||
(_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
|
(_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -2205,9 +2202,9 @@
|
||||||
(build-letrec s #t
|
(build-letrec s #t
|
||||||
(map syntax->datum ids)
|
(map syntax->datum ids)
|
||||||
new-vars
|
new-vars
|
||||||
(map (lambda (x) (chi x r w mod)) #'(val ...))
|
(map (lambda (x) (expand x r w mod)) #'(val ...))
|
||||||
(chi-body #'(e1 e2 ...)
|
(expand-body #'(e1 e2 ...)
|
||||||
(source-wrap e w s mod) r w mod)))))))
|
(source-wrap e w s mod) r w mod)))))))
|
||||||
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
|
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -2223,14 +2220,14 @@
|
||||||
(case type
|
(case type
|
||||||
((lexical)
|
((lexical)
|
||||||
(build-lexical-assignment s (syntax->datum #'id) value
|
(build-lexical-assignment s (syntax->datum #'id) value
|
||||||
(chi #'val r w mod)))
|
(expand #'val r w mod)))
|
||||||
((global)
|
((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)
|
((macro)
|
||||||
(if (procedure-property value 'variable-transformer)
|
(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.
|
;; 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"
|
(syntax-violation 'set! "not a variable transformer"
|
||||||
(wrap e w mod)
|
(wrap e w mod)
|
||||||
(wrap #'id w id-mod))))
|
(wrap #'id w id-mod))))
|
||||||
|
|
@ -2245,7 +2242,7 @@
|
||||||
(lambda (type value ee ww ss modmod)
|
(lambda (type value ee ww ss modmod)
|
||||||
(case type
|
(case type
|
||||||
((module-ref)
|
((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))
|
(call-with-values (lambda () (value #'(head tail ...) r w))
|
||||||
(lambda (e r w s* mod)
|
(lambda (e r w s* mod)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
|
|
@ -2254,8 +2251,8 @@
|
||||||
val mod)))))))
|
val mod)))))))
|
||||||
(else
|
(else
|
||||||
(build-call s
|
(build-call s
|
||||||
(chi #'(setter head) r w mod)
|
(expand #'(setter head) r w mod)
|
||||||
(map (lambda (e) (chi e r w mod))
|
(map (lambda (e) (expand e r w mod))
|
||||||
#'(tail ... val))))))))
|
#'(tail ... val))))))))
|
||||||
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
|
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
|
||||||
|
|
||||||
|
|
@ -2301,15 +2298,15 @@
|
||||||
((_ test then)
|
((_ test then)
|
||||||
(build-conditional
|
(build-conditional
|
||||||
s
|
s
|
||||||
(chi #'test r w mod)
|
(expand #'test r w mod)
|
||||||
(chi #'then r w mod)
|
(expand #'then r w mod)
|
||||||
(build-void no-source)))
|
(build-void no-source)))
|
||||||
((_ test then else)
|
((_ test then else)
|
||||||
(build-conditional
|
(build-conditional
|
||||||
s
|
s
|
||||||
(chi #'test r w mod)
|
(expand #'test r w mod)
|
||||||
(chi #'then r w mod)
|
(expand #'then r w mod)
|
||||||
(chi #'else r w mod))))))
|
(expand #'else r w mod))))))
|
||||||
|
|
||||||
(global-extend 'core 'with-fluids
|
(global-extend 'core 'with-fluids
|
||||||
(lambda (e r w s mod)
|
(lambda (e r w s mod)
|
||||||
|
|
@ -2317,10 +2314,10 @@
|
||||||
((_ ((fluid val) ...) b b* ...)
|
((_ ((fluid val) ...) b b* ...)
|
||||||
(build-dynlet
|
(build-dynlet
|
||||||
s
|
s
|
||||||
(map (lambda (x) (chi x r w mod)) #'(fluid ...))
|
(map (lambda (x) (expand x r w mod)) #'(fluid ...))
|
||||||
(map (lambda (x) (chi x r w mod)) #'(val ...))
|
(map (lambda (x) (expand x r w mod)) #'(val ...))
|
||||||
(chi-body #'(b b* ...)
|
(expand-body #'(b b* ...)
|
||||||
(source-wrap e w s mod) r w mod))))))
|
(source-wrap e w s mod) r w mod))))))
|
||||||
|
|
||||||
(global-extend 'begin 'begin '())
|
(global-extend 'begin 'begin '())
|
||||||
|
|
||||||
|
|
@ -2410,7 +2407,7 @@
|
||||||
no-source
|
no-source
|
||||||
'apply
|
'apply
|
||||||
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
|
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
|
||||||
(chi exp
|
(expand exp
|
||||||
(extend-env
|
(extend-env
|
||||||
labels
|
labels
|
||||||
(map (lambda (var level)
|
(map (lambda (var level)
|
||||||
|
|
@ -2467,14 +2464,14 @@
|
||||||
(and-map (lambda (x) (not (free-id=? #'pat x)))
|
(and-map (lambda (x) (not (free-id=? #'pat x)))
|
||||||
(cons #'(... ...) keys)))
|
(cons #'(... ...) keys)))
|
||||||
(if (free-id=? #'pad #'_)
|
(if (free-id=? #'pad #'_)
|
||||||
(chi #'exp r empty-wrap mod)
|
(expand #'exp r empty-wrap mod)
|
||||||
(let ((labels (list (gen-label)))
|
(let ((labels (list (gen-label)))
|
||||||
(var (gen-var #'pat)))
|
(var (gen-var #'pat)))
|
||||||
(build-call no-source
|
(build-call no-source
|
||||||
(build-simple-lambda
|
(build-simple-lambda
|
||||||
no-source (list (syntax->datum #'pat)) #f (list var)
|
no-source (list (syntax->datum #'pat)) #f (list var)
|
||||||
'()
|
'()
|
||||||
(chi #'exp
|
(expand #'exp
|
||||||
(extend-env labels
|
(extend-env labels
|
||||||
(list (make-binding 'syntax `(,var . 0)))
|
(list (make-binding 'syntax `(,var . 0)))
|
||||||
r)
|
r)
|
||||||
|
|
@ -2505,10 +2502,10 @@
|
||||||
#'(key ...) #'(m ...)
|
#'(key ...) #'(m ...)
|
||||||
r
|
r
|
||||||
mod))
|
mod))
|
||||||
(list (chi #'val r empty-wrap mod))))
|
(list (expand #'val r empty-wrap mod))))
|
||||||
(syntax-violation 'syntax-case "invalid literals list" e))))))))
|
(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
|
;; evaluating) and esew (which stands for "eval syntax expanders
|
||||||
;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
|
;; 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
|
;; if we are compiling a file, and esew is set to
|
||||||
|
|
@ -2519,8 +2516,8 @@
|
||||||
;; the object file if we are compiling a file.
|
;; the object file if we are compiling a file.
|
||||||
(set! macroexpand
|
(set! macroexpand
|
||||||
(lambda* (x #:optional (m 'e) (esew '(eval)))
|
(lambda* (x #:optional (m 'e) (esew '(eval)))
|
||||||
(chi-top-sequence (list x) null-env top-wrap #f m esew
|
(expand-top-sequence (list x) null-env top-wrap #f m esew
|
||||||
(cons 'hygiene (module-name (current-module))))))
|
(cons 'hygiene (module-name (current-module))))))
|
||||||
|
|
||||||
(set! identifier?
|
(set! identifier?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
|
|
||||||
|
|
@ -66,9 +66,7 @@
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define block-growth-factor
|
(define block-growth-factor
|
||||||
(let ((f (make-fluid)))
|
(make-fluid 2))
|
||||||
(fluid-set! f 2)
|
|
||||||
f))
|
|
||||||
|
|
||||||
(define-syntax-rule (define-inline (name formals ...) body ...)
|
(define-syntax-rule (define-inline (name formals ...) body ...)
|
||||||
;; Work around the lack of an inliner.
|
;; Work around the lack of an inliner.
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; Guile Emacs Lisp
|
;;; 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
|
;;; This library is free software; you can redistribute it and/or
|
||||||
;;; modify it under the terms of the GNU Lesser General Public
|
;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -131,8 +131,8 @@
|
||||||
((_ name value)
|
((_ name value)
|
||||||
(with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
|
(with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
|
||||||
#'(begin
|
#'(begin
|
||||||
(define-public scheme-name (make-fluid))
|
(define-public scheme-name
|
||||||
(fluid-set! scheme-name (cons 'macro value))))))))
|
(make-fluid (cons 'macro value)))))))))
|
||||||
|
|
||||||
(define-syntax defspecial
|
(define-syntax defspecial
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
|
@ -140,10 +140,10 @@
|
||||||
((_ name args body ...)
|
((_ name args body ...)
|
||||||
(with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
|
(with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
|
||||||
#'(begin
|
#'(begin
|
||||||
(define scheme-name (make-fluid))
|
(define scheme-name
|
||||||
(fluid-set! scheme-name
|
(make-fluid
|
||||||
(cons 'special-operator
|
(cons 'special-operator
|
||||||
(lambda args body ...)))))))))
|
(lambda args body ...))))))))))
|
||||||
|
|
||||||
;;; Call a guile-primitive that may be rebound for elisp and thus needs
|
;;; Call a guile-primitive that may be rebound for elisp and thus needs
|
||||||
;;; absolute addressing.
|
;;; absolute addressing.
|
||||||
|
|
|
||||||
|
|
@ -30,6 +30,7 @@
|
||||||
|
|
||||||
(define-module (scripts compile)
|
(define-module (scripts compile)
|
||||||
#:use-module ((system base compile) #:select (compile-file))
|
#:use-module ((system base compile) #:select (compile-file))
|
||||||
|
#:use-module (system base target)
|
||||||
#:use-module (system base message)
|
#:use-module (system base message)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-13)
|
#:use-module (srfi srfi-13)
|
||||||
|
|
@ -88,7 +89,12 @@
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(if (assoc-ref result 'to)
|
(if (assoc-ref result 'to)
|
||||||
(fail "`--to' option cannot be specified more than once")
|
(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)
|
(define (parse-args args)
|
||||||
"Parse argument list @var{args} and return an alist with all the relevant
|
"Parse argument list @var{args} and return an alist with all the relevant
|
||||||
|
|
@ -109,7 +115,7 @@ options."
|
||||||
|
|
||||||
(define (show-version)
|
(define (show-version)
|
||||||
(format #t "compile (GNU Guile) ~A~%" (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>.
|
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.
|
This is free software: you are free to change and redistribute it.
|
||||||
There is NO WARRANTY, to the extent permitted by law.~%"))
|
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)))
|
o)))
|
||||||
(from (or (assoc-ref options 'from) 'scheme))
|
(from (or (assoc-ref options 'from) 'scheme))
|
||||||
(to (or (assoc-ref options 'to) 'objcode))
|
(to (or (assoc-ref options 'to) 'objcode))
|
||||||
|
(target (or (assoc-ref options 'target) %host-type))
|
||||||
(input-files (assoc-ref options 'input-files))
|
(input-files (assoc-ref options 'input-files))
|
||||||
(output-file (assoc-ref options 'output-file))
|
(output-file (assoc-ref options 'output-file))
|
||||||
(load-path (assoc-ref options 'load-path)))
|
(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'
|
-f, --from=LANG specify a source language other than `scheme'
|
||||||
-t, --to=LANG specify a target language other than `objcode'
|
-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.
|
Note that auto-compilation will be turned off.
|
||||||
|
|
||||||
|
|
@ -171,11 +179,13 @@ Report bugs to <~A>.~%"
|
||||||
(for-each (lambda (file)
|
(for-each (lambda (file)
|
||||||
(format #t "wrote `~A'\n"
|
(format #t "wrote `~A'\n"
|
||||||
(with-fluids ((*current-warning-prefix* ""))
|
(with-fluids ((*current-warning-prefix* ""))
|
||||||
(compile-file file
|
(with-target target
|
||||||
#:output-file output-file
|
(lambda ()
|
||||||
#:from from
|
(compile-file file
|
||||||
#:to to
|
#:output-file output-file
|
||||||
#:opts compile-opts))))
|
#:from from
|
||||||
|
#:to to
|
||||||
|
#:opts compile-opts))))))
|
||||||
input-files)))
|
input-files)))
|
||||||
|
|
||||||
(define main compile)
|
(define main compile)
|
||||||
|
|
|
||||||
|
|
@ -57,37 +57,41 @@
|
||||||
(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
|
(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
|
||||||
|
|
||||||
(define (make-parameter/helper val conv)
|
(define (make-parameter/helper val conv)
|
||||||
(let ((value (make-fluid))
|
(let ((fluid (make-fluid (conv val))))
|
||||||
(conv conv))
|
(case-lambda
|
||||||
(begin
|
(()
|
||||||
(fluid-set! value (conv val))
|
(fluid-ref fluid))
|
||||||
(lambda new-value
|
((new-value)
|
||||||
(cond
|
(cond
|
||||||
((null? new-value) (fluid-ref value))
|
((eq? new-value get-fluid-tag) fluid)
|
||||||
((eq? (car new-value) get-fluid-tag) value)
|
((eq? new-value get-conv-tag) conv)
|
||||||
((eq? (car new-value) get-conv-tag) conv)
|
(else (fluid-set! fluid (conv new-value))))))))
|
||||||
((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
|
|
||||||
(else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
|
|
||||||
|
|
||||||
(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
|
(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
|
||||||
(with-parameters* (list ?param ...)
|
(with-parameters* (list ?param ...)
|
||||||
(list ?value ...)
|
(list ?value ...)
|
||||||
(lambda () ?body ...)))
|
(lambda () ?body ...)))
|
||||||
|
|
||||||
(define (current-input-port . new-value)
|
(define current-input-port
|
||||||
(if (null? new-value)
|
(case-lambda
|
||||||
((@ (guile) current-input-port))
|
(()
|
||||||
(apply set-current-input-port new-value)))
|
((@ (guile) current-input-port)))
|
||||||
|
((new-value)
|
||||||
|
(set-current-input-port new-value))))
|
||||||
|
|
||||||
(define (current-output-port . new-value)
|
(define current-output-port
|
||||||
(if (null? new-value)
|
(case-lambda
|
||||||
((@ (guile) current-output-port))
|
(()
|
||||||
(apply set-current-output-port new-value)))
|
((@ (guile) current-output-port)))
|
||||||
|
((new-value)
|
||||||
|
(set-current-output-port new-value))))
|
||||||
|
|
||||||
(define (current-error-port . new-value)
|
(define current-error-port
|
||||||
(if (null? new-value)
|
(case-lambda
|
||||||
((@ (guile) current-error-port))
|
(()
|
||||||
(apply set-current-error-port new-value)))
|
((@ (guile) current-error-port)))
|
||||||
|
((new-value)
|
||||||
|
(set-current-error-port new-value))))
|
||||||
|
|
||||||
(define port-list
|
(define port-list
|
||||||
(list current-input-port current-output-port current-error-port))
|
(list current-input-port current-output-port current-error-port))
|
||||||
|
|
|
||||||
|
|
@ -111,7 +111,7 @@
|
||||||
;;; Current language
|
;;; Current language
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define *current-language* (make-fluid))
|
(define *current-language* (make-fluid 'scheme))
|
||||||
|
|
||||||
(define (current-language)
|
(define (current-language)
|
||||||
(or (fluid-ref *current-language*) 'scheme))
|
(fluid-ref *current-language*))
|
||||||
|
|
|
||||||
|
|
@ -56,15 +56,13 @@
|
||||||
|
|
||||||
(define *current-warning-port*
|
(define *current-warning-port*
|
||||||
;; The port where warnings are sent.
|
;; The port where warnings are sent.
|
||||||
(make-fluid))
|
(make-fluid (current-error-port)))
|
||||||
|
|
||||||
(fluid-set! *current-warning-port* (current-error-port))
|
(fluid-set! *current-warning-port* (current-error-port))
|
||||||
|
|
||||||
(define *current-warning-prefix*
|
(define *current-warning-prefix*
|
||||||
;; Prefix string when emitting a warning.
|
;; Prefix string when emitting a warning.
|
||||||
(make-fluid))
|
(make-fluid ";;; "))
|
||||||
|
|
||||||
(fluid-set! *current-warning-prefix* ";;; ")
|
|
||||||
|
|
||||||
|
|
||||||
(define-record-type <warning-type>
|
(define-record-type <warning-type>
|
||||||
|
|
|
||||||
|
|
@ -21,6 +21,7 @@
|
||||||
|
|
||||||
(define-module (system base target)
|
(define-module (system base target)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
|
#:use-module (ice-9 regex)
|
||||||
#:export (target-type with-target
|
#:export (target-type with-target
|
||||||
|
|
||||||
target-cpu target-vendor target-os
|
target-cpu target-vendor target-os
|
||||||
|
|
@ -33,44 +34,90 @@
|
||||||
;;; Target types
|
;;; 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)
|
(define %target-type (make-fluid %host-type))
|
||||||
(or (fluid-ref %target-type)
|
(define %target-endianness (make-fluid (native-endianness)))
|
||||||
%host-type))
|
(define %target-word-size (make-fluid %native-word-size))
|
||||||
|
|
||||||
(define (validate-target target)
|
(define (validate-target target)
|
||||||
(if (or (not (string? target))
|
(if (or (not (string? target))
|
||||||
(let ((parts (string-split target #\-)))
|
(let ((parts (string-split target #\-)))
|
||||||
(or (< 3 (length parts))
|
(or (< (length parts) 3)
|
||||||
(or-map string-null? parts))))
|
(or-map string-null? parts))))
|
||||||
(error "invalid target" target)))
|
(error "invalid target" target)))
|
||||||
|
|
||||||
(define (with-target target thunk)
|
(define (with-target target thunk)
|
||||||
(validate-target target)
|
(validate-target target)
|
||||||
(with-fluids ((%target-type target))
|
(let ((cpu (triplet-cpu target)))
|
||||||
(thunk)))
|
(with-fluids ((%target-type target)
|
||||||
|
(%target-endianness (cpu-endianness cpu))
|
||||||
|
(%target-word-size (cpu-word-size cpu)))
|
||||||
|
(thunk))))
|
||||||
|
|
||||||
(define (target-cpu)
|
(define (cpu-endianness cpu)
|
||||||
(let ((t (target-type)))
|
"Return the endianness for CPU."
|
||||||
(substring t 0 (string-index t #\-))))
|
(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)
|
(define (cpu-word-size cpu)
|
||||||
(let* ((t (target-type))
|
"Return the word size for CPU."
|
||||||
(start (1+ (string-index t #\-))))
|
(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))))
|
(substring t start (string-index t #\- start))))
|
||||||
|
|
||||||
(define (target-os)
|
(define (triplet-os t)
|
||||||
(let* ((t (target-type))
|
(let ((start (1+ (string-index t #\- (1+ (string-index t #\-))))))
|
||||||
(start (1+ (string-index t #\- (1+ (string-index t #\-))))))
|
|
||||||
(substring t start)))
|
(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)
|
(define (target-endianness)
|
||||||
(if (equal? (target-type) %host-type)
|
"Return the endianness object of the target platform."
|
||||||
(native-endianness)
|
(fluid-ref %target-endianness))
|
||||||
(error "cross-compilation not yet handled" %host-type (target-type))))
|
|
||||||
|
|
||||||
(define (target-word-size)
|
(define (target-word-size)
|
||||||
(if (equal? (target-type) %host-type)
|
"Return the word size, in bytes, of the target platform."
|
||||||
((@ (system foreign) sizeof) '*)
|
(fluid-ref %target-word-size))
|
||||||
(error "cross-compilation not yet handled" %host-type (target-type))))
|
|
||||||
|
|
|
||||||
|
|
@ -134,7 +134,9 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
|
||||||
|
|
||||||
(define %make-repl make-repl)
|
(define %make-repl make-repl)
|
||||||
(define* (make-repl lang #:optional debug)
|
(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)
|
#:options (copy-tree repl-default-options)
|
||||||
#:tm-stats (times)
|
#:tm-stats (times)
|
||||||
#:gc-stats (gc-stats)
|
#:gc-stats (gc-stats)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;;; (texinfo plain-text) -- rendering stexinfo as plain text
|
;;;; (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>
|
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
|
||||||
;;;;
|
;;;;
|
||||||
;;;; This library is free software; you can redistribute it and/or
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
|
|
@ -41,9 +41,6 @@
|
||||||
(or (arg-ref key %-args)
|
(or (arg-ref key %-args)
|
||||||
(error "Missing argument:" key %-args)))
|
(error "Missing argument:" key %-args)))
|
||||||
|
|
||||||
(define *indent* (make-fluid))
|
|
||||||
(define *itemizer* (make-fluid))
|
|
||||||
|
|
||||||
(define (make-ticker str)
|
(define (make-ticker str)
|
||||||
(lambda () str))
|
(lambda () str))
|
||||||
(define (make-enumerator n)
|
(define (make-enumerator n)
|
||||||
|
|
@ -52,9 +49,8 @@
|
||||||
(set! n (1+ n))
|
(set! n (1+ n))
|
||||||
(format #f "~A. " last))))
|
(format #f "~A. " last))))
|
||||||
|
|
||||||
(fluid-set! *indent* "")
|
(define *indent* (make-fluid ""))
|
||||||
;; Shouldn't be necessary to do this, but just in case.
|
(define *itemizer* (make-fluid (make-ticker "* ")))
|
||||||
(fluid-set! *itemizer* (make-ticker "* "))
|
|
||||||
|
|
||||||
(define-macro (with-indent n . body)
|
(define-macro (with-indent n . body)
|
||||||
`(with-fluids ((*indent* (string-append (fluid-ref *indent*)
|
`(with-fluids ((*indent* (string-append (fluid-ref *indent*)
|
||||||
|
|
|
||||||
|
|
@ -470,7 +470,7 @@ ordered alist."
|
||||||
val)
|
val)
|
||||||
|
|
||||||
(define (default-val-validator k val)
|
(define (default-val-validator k val)
|
||||||
(string? val))
|
(or (not val) (string? val)))
|
||||||
|
|
||||||
(define (default-val-writer k val port)
|
(define (default-val-writer k val port)
|
||||||
(if (or (string-index val #\;)
|
(if (or (string-index val #\;)
|
||||||
|
|
@ -518,9 +518,9 @@ ordered alist."
|
||||||
((pair? elt)
|
((pair? elt)
|
||||||
(let ((k (car elt))
|
(let ((k (car elt))
|
||||||
(v (cdr elt)))
|
(v (cdr elt)))
|
||||||
(and (or (string? k) (symbol? k))
|
(and (symbol? k)
|
||||||
(valid? k v))))
|
(valid? k v))))
|
||||||
((or (string? elt) (symbol? elt))
|
((symbol? elt)
|
||||||
(valid? elt #f))
|
(valid? elt #f))
|
||||||
(else #f)))))
|
(else #f)))))
|
||||||
|
|
||||||
|
|
@ -611,7 +611,7 @@ ordered alist."
|
||||||
(valid? default-val-validator))
|
(valid? default-val-validator))
|
||||||
(list-of? list
|
(list-of? list
|
||||||
(lambda (elt)
|
(lambda (elt)
|
||||||
(key-value-list? list valid?))))
|
(key-value-list? elt valid?))))
|
||||||
|
|
||||||
(define* (write-param-list list port #:optional
|
(define* (write-param-list list port #:optional
|
||||||
(val-writer default-val-writer))
|
(val-writer default-val-writer))
|
||||||
|
|
@ -871,7 +871,10 @@ ordered alist."
|
||||||
(cons scheme (parse-key-value-list str default-val-parser delim end)))))))
|
(cons scheme (parse-key-value-list str default-val-parser delim end)))))))
|
||||||
|
|
||||||
(define (validate-credentials val)
|
(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)
|
(define (write-credentials val port)
|
||||||
(display (car val) port)
|
(display (car val) port)
|
||||||
|
|
@ -1137,7 +1140,7 @@ phrase\"."
|
||||||
(lambda (str)
|
(lambda (str)
|
||||||
(map string->symbol (split-and-trim str)))
|
(map string->symbol (split-and-trim str)))
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(list-of? symbol? v))
|
(list-of? v symbol?))
|
||||||
(lambda (v port)
|
(lambda (v port)
|
||||||
(write-list v port display ", "))))
|
(write-list v port display ", "))))
|
||||||
|
|
||||||
|
|
@ -1242,7 +1245,14 @@ phrase\"."
|
||||||
((private no-cache)
|
((private no-cache)
|
||||||
(and v-str (split-header-names v-str)))
|
(and v-str (split-header-names v-str)))
|
||||||
(else 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)
|
(lambda (k v port)
|
||||||
(cond
|
(cond
|
||||||
((string? v) (display v port))
|
((string? v) (display v port))
|
||||||
|
|
@ -1522,7 +1532,7 @@ phrase\"."
|
||||||
(lambda (k v)
|
(lambda (k v)
|
||||||
(if (eq? k 'q)
|
(if (eq? k 'q)
|
||||||
(valid-quality? v)
|
(valid-quality? v)
|
||||||
(string? v)))
|
(or (not v) (string? v))))
|
||||||
(lambda (k v port)
|
(lambda (k v port)
|
||||||
(if (eq? k 'q)
|
(if (eq? k 'q)
|
||||||
(write-quality v port)
|
(write-quality v port)
|
||||||
|
|
|
||||||
|
|
@ -425,8 +425,7 @@
|
||||||
(append (current-test-prefix) (list name)))
|
(append (current-test-prefix) (list name)))
|
||||||
|
|
||||||
;;; A fluid containing the current test prefix, as a list.
|
;;; A fluid containing the current test prefix, as a list.
|
||||||
(define prefix-fluid (make-fluid))
|
(define prefix-fluid (make-fluid '()))
|
||||||
(fluid-set! prefix-fluid '())
|
|
||||||
(define (current-test-prefix)
|
(define (current-test-prefix)
|
||||||
(fluid-ref prefix-fluid))
|
(fluid-ref prefix-fluid))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,15 +1,17 @@
|
||||||
;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
|
;;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
;;;; License as published by the Free Software Foundation; either
|
;;;; License as published by the Free Software Foundation; either
|
||||||
;;;; version 3 of the License, or (at your option) any later version.
|
;;;; version 3 of the License, or (at your option) any later version.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; This library is distributed in the hope that it will be useful,
|
;;;; This library is distributed in the hope that it will be useful,
|
||||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
;;;; Lesser General Public License for more details.
|
;;;; Lesser General Public License for more details.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; You should have received a copy of the GNU Lesser General Public
|
;;;; You should have received a copy of the GNU Lesser General Public
|
||||||
;;;; License along with this library; if not, write to the Free Software
|
;;;; License along with this library; if not, write to the Free Software
|
||||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
;;;; 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 ((rnrs io ports) #:select (open-bytevector-output-port))
|
||||||
#:use-module (test-suite lib)
|
#:use-module (test-suite lib)
|
||||||
#:use-module (system vm instruction)
|
#:use-module (system vm instruction)
|
||||||
|
#:use-module (system vm objcode)
|
||||||
|
#:use-module (system base target)
|
||||||
#:use-module (language assembly)
|
#:use-module (language assembly)
|
||||||
#:use-module (language assembly compile-bytecode))
|
#:use-module (language assembly compile-bytecode))
|
||||||
|
|
||||||
|
|
@ -114,3 +118,80 @@
|
||||||
(uint32 0) ;; metalen
|
(uint32 0) ;; metalen
|
||||||
make-int8 3
|
make-int8 3
|
||||||
return))))
|
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:
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*-
|
;;;; 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
|
;;;; Ludovic Courtès
|
||||||
;;;;
|
;;;;
|
||||||
;;;; This library is free software; you can redistribute it and/or
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
|
|
@ -42,7 +42,14 @@
|
||||||
(and (bytevector=? (make-bytevector 20 7)
|
(and (bytevector=? (make-bytevector 20 7)
|
||||||
(make-bytevector 20 7))
|
(make-bytevector 20 7))
|
||||||
(not (bytevector=? (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"
|
(with-test-prefix/c&e "2.3 Operations on Bytes and Octets"
|
||||||
|
|
|
||||||
|
|
@ -231,10 +231,10 @@
|
||||||
|
|
||||||
(with-test-prefix "define set procedure-name"
|
(with-test-prefix "define set procedure-name"
|
||||||
|
|
||||||
(expect-fail "closure"
|
(pass-if "closure"
|
||||||
(eq? 'foo-closure (procedure-name bar-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))))
|
(eq? 'foo-pws (procedure-name bar-pws))))
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -330,78 +330,49 @@
|
||||||
0))
|
0))
|
||||||
|
|
||||||
(with-test-prefix "stacks"
|
(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"
|
(pass-if "arguments of a primitive stack frame"
|
||||||
;; The subr involving the error must appear exactly once on the stack.
|
;; Create a stack with two primitive frames and make sure the
|
||||||
(catch 'result
|
;; arguments are correct.
|
||||||
(lambda ()
|
(catch 'result
|
||||||
(throw 'unresolved)
|
(lambda ()
|
||||||
(start-stack 'foo
|
(start-stack 'foo
|
||||||
(lazy-catch 'wrong-type-arg
|
(with-throw-handler 'wrong-type-arg
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;; Trigger a `wrong-type-arg' exception.
|
;; Trigger a `wrong-type-arg' exception.
|
||||||
(fluid-ref 'not-a-fluid))
|
(substring 'wrong 'type 'arg))
|
||||||
(lambda _
|
(lambda _
|
||||||
(let* ((stack (make-stack #t))
|
(let* ((stack (make-stack #t))
|
||||||
(frames (stack->frames stack)))
|
(frames (stack->frames stack)))
|
||||||
(throw 'result
|
(throw 'result
|
||||||
(count (lambda (frame)
|
(map (lambda (frame)
|
||||||
(and (frame-procedure? frame)
|
(cons (frame-procedure frame)
|
||||||
(eq? (frame-procedure frame)
|
(frame-arguments frame)))
|
||||||
fluid-ref)))
|
frames)))))))
|
||||||
frames)))))))
|
(lambda (key result)
|
||||||
(lambda (key result)
|
(and (equal? (car result) `(,make-stack #t))
|
||||||
(= 1 result))))
|
(pair? (member `(,substring wrong type arg)
|
||||||
|
(cdr 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)))))))))
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; letrec init evaluation
|
;;; letrec init evaluation
|
||||||
|
|
|
||||||
|
|
@ -254,6 +254,16 @@
|
||||||
(map proc* arg1 arg2 arg3)))
|
(map proc* arg1 arg2 arg3)))
|
||||||
(throw 'unresolved)))
|
(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"
|
(pass-if "procedures returning void"
|
||||||
(if (defined? 'procedure->pointer)
|
(if (defined? 'procedure->pointer)
|
||||||
(let* ((called? #f)
|
(let* ((called? #f)
|
||||||
|
|
@ -262,6 +272,22 @@
|
||||||
(proc* (pointer->procedure void pointer '())))
|
(proc* (pointer->procedure void pointer '())))
|
||||||
(proc*)
|
(proc*)
|
||||||
called?)
|
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))))
|
(throw 'unresolved))))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
|
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
|
||||||
;;;; Ludovic Courtès <ludo@gnu.org>
|
;;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -26,7 +26,12 @@
|
||||||
(eq? 'display (procedure-name display)))
|
(eq? 'display (procedure-name display)))
|
||||||
|
|
||||||
(pass-if "gsubr"
|
(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"
|
(with-test-prefix "procedure-arity"
|
||||||
|
|
@ -52,4 +57,19 @@
|
||||||
|
|
||||||
(pass-if "list"
|
(pass-if "list"
|
||||||
(equal? (procedure-minimum-arity 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))))
|
||||||
|
|
|
||||||
|
|
@ -41,8 +41,9 @@
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ sym str val)
|
((_ sym str val)
|
||||||
(pass-if (format #f "~a: ~s -> ~s" 'sym str val)
|
(pass-if (format #f "~a: ~s -> ~s" 'sym str val)
|
||||||
(equal? (parse-header 'sym str)
|
(and (equal? (parse-header 'sym str)
|
||||||
val)))))
|
val)
|
||||||
|
(valid-header? 'sym val))))))
|
||||||
|
|
||||||
(define-syntax pass-if-any-error
|
(define-syntax pass-if-any-error
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue