summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/ChangeLog250
-rw-r--r--libguile/Makefile.am4
-rw-r--r--libguile/backtrace.c1
-rw-r--r--libguile/debug.c11
-rw-r--r--libguile/debug.h23
-rw-r--r--libguile/deprecated.h4
-rw-r--r--libguile/deprecation.c3
-rw-r--r--libguile/eq.c3
-rw-r--r--libguile/eval.c2082
-rw-r--r--libguile/eval.h19
-rw-r--r--libguile/eval.i.c1942
-rw-r--r--libguile/feature.c18
-rw-r--r--libguile/feature.h3
-rw-r--r--libguile/filesys.c40
-rw-r--r--libguile/gc.c4
-rw-r--r--libguile/gsubr.c2
-rw-r--r--libguile/i18n.c864
-rw-r--r--libguile/i18n.h2
-rw-r--r--libguile/init.c1
-rw-r--r--libguile/macros.c2
-rw-r--r--libguile/numbers.c61
-rw-r--r--libguile/numbers.h8
-rw-r--r--libguile/options.c59
-rw-r--r--libguile/options.h5
-rw-r--r--libguile/posix.c101
-rw-r--r--libguile/print.c16
-rw-r--r--libguile/print.h9
-rw-r--r--libguile/private-gc.h21
-rw-r--r--libguile/private-options.h103
-rw-r--r--libguile/read.c15
-rw-r--r--libguile/read.h14
-rw-r--r--libguile/regex-posix.c27
-rw-r--r--libguile/scmsigs.c24
-rw-r--r--libguile/srcprop.c104
-rw-r--r--libguile/srcprop.h34
-rw-r--r--libguile/stacks.c2
-rw-r--r--libguile/struct.c9
-rw-r--r--libguile/symbols.c3
-rw-r--r--libguile/threads.c56
-rw-r--r--libguile/throw.c28
-rw-r--r--libguile/version.h.in12
41 files changed, 3534 insertions, 2455 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 8ba446c6c..2762daec6 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,16 +1,262 @@
+2007-02-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (noinst_HEADERS): Add private-options.h, so that it
+ is included in the distribution.
+
+2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * i18n.c: Include "libguile/threads.h" and "libguile/posix.h"
+ unconditionally. Include <langinfo.h> and <nl_types.h> when
+ available.
+ (SCM_I18N_STRINGIFY, SCM_LOCALE_CATEGORY_MASK,
+ SCM_LIST_OR_INTEGER_P): New macros.
+ (LC_*_MASK): When `USE_GNU_LOCALE_API' is undefined, define them
+ as powers of two instead of `(1 << LC_*)'.
+ (scm_i_locale_free): New function/macro.
+ (scm_global_locale): New global variable.
+ (smob_locale_free): Use `scm_i_locale_free ()'.
+ (smob_locale_mark): Check whether the SMOB is `%global-locale'.
+ (get_current_locale_settings): Return `EINVAL' instead of `errno'
+ when `setlocale' fails.
+ (restore_locale_settings): Likewise.
+ (install_locale_categories): Likewise.
+ (install_locale): Likewise. Stop the locale stack traversal when
+ all categories have been handled.
+ (get_current_locale, category_to_category_mask,
+ category_list_to_category_mask): New function.
+ (scm_make_locale): Use them. Accept both lists of `LC_*' values
+ and single `LC_*' values as the first argument. Handle the case
+ where BASE_LOCALE is `%global-locale'. When `USE_GNU_LOCALE_API',
+ duplicate C_BASE_LOCALE before using it.
+ (scm_nl_langinfo, define_langinfo_items): New functions.
+ (scm_init_i18n): When `HAVE_NL_LANGINFO', add feature
+ `nl-langinfo' and invoke `define_langinfo_items ()'.
+ * i18n.h (scm_global_locale, scm_nl_langinfo): New declarations.
+ * posix.c: Include <xlocale.h> when available.
+ (scm_i_locale_mutex): Always define it. Statically initialized.
+ (scm_set_locale): Invoke `scm_i_to_lc_category ()' before
+ acquiring the locale mutex.
+ (scm_init_posix): No longer initialize SCM_I_LOCALE_MUTEX here.
+
+2007-01-25 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * vector.c: remove comment as per kryde's request.
+
+2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * vectors.c (s_scm_vector_move_right_x): complain about naming.
+
+ * srcprop.c: regularize comments.
+
+ * eval.c: remove superfluous ifndef DEVAL.
+
+ * private-options.h: idem.
+
+ * eval.i.c: copyright nitpicking.
+
+ * eval.c: distangle. move duplicate code to eval.i.c and include
+ twice.
+
+ * eval.i.c: new file.
+
+ * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c
+ eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c,
+ read.h, stacks.c, symbols.c, throw.c: use private-options.h
+
+ * private-options.h: new file: contain hardcoded option
+ definitions.
+
+ * private-gc.h: add FSF header.
+
+2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * debug.h (SCM_RESET_DEBUG_MODE): switch to debugging if
+ memoize-symbol is set.
+
+ * eval.h (SCM_MEMOIZE_HDLR): add macros for memoize symbol trap.
+
+ * eval.c (CEVAL): add memoize_symbol trap.
+
+ * options.c (scm_options_try): new function. This allows error
+ reporting before changing options in a critical section.
+
+ * srcprop.c: use double cell for storing source-properties. Put
+ filename in the plist, and share between srcprops if possible.
+ Remove specialized storage.
+
+ * srcprop.h: remove macros without SCM_ prefix from
+ interface. Remove specialized storage/type definitions.
+
+ * read.c: idem.
+
+ * print.c: idem.
+
+ * eval.c: terminate option lists with 0.
+
+ * options.c: remove n (for length) from scm_option_X
+ functions. Detect option list length by looking for NULL name.
+
+2007-01-19 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * struct.c (scm_i_struct_equalp): Skip comparison if both FIELD1
+ is equal to S1 and FIELD2 is equal to S2. This avoids infinite
+ recursion when comparing `s' fields, as the REQUIRED_VTABLE_FIELDS
+ added by `make-vtable-vtable'. Reported by Marco Maggi.
+
+2007-01-18 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * throw.c (scm_ithrow): more refined error message: print symbols
+ too.
+
+2007-01-16 Kevin Ryde <user42@zip.com.au>
+
+ * feature.c, feature.h (scm_set_program_arguments_scm): New function,
+ implementing `set-program-arguments'.
+
+ * filesys.c (scm_init_filesys): Use scm_from_int rather than
+ scm_from_long for O_RDONLY, O_WRONLY, O_RDWR, O_CREAT, O_EXCL,
+ O_NOCTTY, O_TRUNC, O_APPEND, O_NONBLOCK, O_NDELAY, O_SYNC and
+ O_LARGEFILE. These are all int not long, per arg to open().
+ (scm_init_filesys): Use scm_from_int rather than scm_from_long for
+ F_DUPFD, F_GETFD, F_SETFD, F_GETFL, F_SETFL, F_GETOWN, F_SETOWN, these
+ are all ints (per command arg to fcntl). Likewise FD_CLOEXEC which is
+ an int arg to fcntl.
+
+ * posix.c (scm_putenv): Correction to "len" variable, was defined only
+ for __MINGW32__ but used under any !HAVE_UNSETENV (such as solaris).
+ Move it to where it's used. Reported by Hugh Sasse.
+
+ * regex-posix.c (scm_regexp_exec): Remove SCM_CRITICAL_SECTION_START
+ and SCM_CRITICAL_SECTION_END, believe not needed. Their placement
+ meant #\nul in the input (detected by scm_to_locale_string) and a bad
+ flags arg (detected by scm_to_int) would throw from a critical
+ section, causing an abort().
+
+ * regex-posix.c (scm_init_regex_posix): Use scm_from_int for
+ REG_BASIC, REG_EXTENDED, REG_ICASE, REG_NEWLINE, REG_NOTBOL,
+ REG_NOTEOL; they're all ints not longs (per args to regcomp and
+ regexec).
+
+2007-01-10 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * throw.c (scm_ithrow): print out key symbol and string arguments
+ when error happens inside a critical section, and document why.
+
+2007-01-06 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * read.c (s_scm_read_hash_extend): document #f argument to
+ read-hash-extend.
+
+2007-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * deprecated.h (scm_create_hook), version.h.in (scm_major_version,
+ scm_minor_version, scm_micro_version, scm_effective_version,
+ scm_version, scm_init_version): Use SCM_API instead of just extern,
+ for the benefit of mingw. Reported by Cesar Strauss.
+
+2007-01-03 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * gc.c (s_scm_gc_stats): return an entry for total-cells-allocated
+ too.
+ (gc_update_stats): update scm_gc_cells_allocated_acc too.
+
+2006-12-27 Kevin Ryde <user42@zip.com.au>
+
+ * threads.c (get_thread_stack_base): In mingw with pthreads we can use
+ the basic scm_get_stack_base. As advised by Nils Durner.
+
+ * threads.c (get_thread_stack_base): Add a version using
+ pthread_get_stackaddr_np (when available), for the benefit of MacOS.
+ As advised by Heikki Lindholm.
+
+ * scmsigs.c (signal_delivery_thread): Restrict scm_i_pthread_sigmask
+ to HAVE_PTHREAD_SIGMASK, it doesn't exist on mingw. Reported by Nils
+ Durner.
+
+2006-12-24 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_kill): When only raise() is available, throw an ENOSYS
+ error if pid is not our own process, instead of silently doing nothing.
+
+ * print.c (scm_write, scm_display, scm_write_char): Disable port close
+ on EPIPE. This was previously disabled but introduction of HAVE_PIPE
+ check in configure.in unintentionally enabled it. Believe that
+ testing errno after scm_prin1 or scm_putc is bogus, a long ago error
+ can leave errno in that state. popen.test "no duplicates" output test
+ provoked that.
+
+2006-12-23 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * numbers.c (scm_i_fraction_reduce): move logic into
+ scm_i_make_ratio(), so fractions are only read.
+ scm_i_fraction_reduce() modifies a fraction when reading it. A
+ race condition might lead to fractions being corrupted by reading
+ them concurrently.
+
+ Also, the REDUCED bit alters the SCM_CELL_TYPE(), making
+ comparisons between reduced and unreduced fractions go wrong.
+
+ * numbers.h: remove SCM_FRACTION_SET_NUMERATOR,
+ SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT,
+ SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR,
+ SCM_FRACTION_REDUCED.
+
+2006-12-16 Kevin Ryde <user42@zip.com.au>
+
+ * scmsigs.c (scm_raise): Use raise() rather than kill(), as this is
+ more direct for a procedure called raise.
+ (kill): Remove mingw fake fallback.
+
+2006-12-15 Kevin Ryde <user42@zip.com.au>
+
+ * scmsigs.c: Conditionalize process.h, add io.h believe needed for
+ _pipe on mingw.
+
+2006-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * threads.c (thread_print): Cope with the case where pthread_t is a
+ struct, as found on mingw. Can't just cast to size_t for printing.
+ Reported by Nils Durner.
+
+ * scmsigs.c: Add <fcntl.h> and <process.h> needed by mingw. Copy the
+ fallback pipe() using _pipe() from posix.c. Reported by Nils Durner.
+
+2006-12-13 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c (scm_m_define): Set 'name procedure property on any
+ scm_procedure_p, not just SCM_CLOSUREP. In particular this picks up
+ procedures with setters as used in srfi-17.
+
+ * posix.c (scm_crypt): Check for NULL return from crypt(), which the
+ linux man page says is a possibility.
+
2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
* libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES
- instead of RES (reported by Gyula Szavai). This allows the use of
+ instead of RES (reported by Szavai Gyula). This allows the use of
negative lower bounds.
(scm_i_read_array): Make sure LEN is non-negative (reported by
- Gyula Szavai).
+ Szavai Gyula).
(scm_array_in_bounds_p): Iterate over S instead of always
comparing indices with the bounds of S[0]. This fixes
`array-in-bounds?' for arrays with a rank greater than one and
with different lower bounds for each dimension.
+2006-12-05 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_product): For flonum*inum and complex*inum, return
+ exact 0 if inum==0. Already done for inum*flonum and inum*complex,
+ and as per R5RS section "Exactness".
+
+2006-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (.c.doc): Remove the "test -n" apparently attempting to
+ allow $AWK from the environment to override. It had syntax gremlins,
+ and the presence of a $(AWK) variable set by AC_PROG_AWK in the
+ Makefile stopped it having any effect. Use just $(AWK), which can be
+ overridden with "make AWK=xxx" in the usual way if desired.
+
2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
* libguile/vectors.c (scm_vector_to_list): Fixed list
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 6e1fa8634..3944f2e46 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -182,7 +182,7 @@ noinst_HEADERS = convert.i.c \
srfi-4.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
- private-gc.h
+ private-gc.h private-options.h
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@
@@ -283,7 +283,7 @@ SUFFIXES = .x .doc
.c.x:
./guile-snarf -o $@ $< $(snarfcppopts)
.c.doc:
- -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<)
+ -$(AWK) -f ./guile-func-name-check $<
(./guile-snarf-docs $(snarfcppopts) $< | \
./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; }
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 38d7a8382..a8bc12059 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -47,6 +47,7 @@
#include "libguile/lang.h"
#include "libguile/backtrace.h"
#include "libguile/filesys.h"
+#include "libguile/private-options.h"
/* {Error reporting and backtraces}
*
diff --git a/libguile/debug.c b/libguile/debug.c
index 653c458a2..280e92b7d 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -42,8 +42,11 @@
#include "libguile/validate.h"
#include "libguile/debug.h"
+
+#include "libguile/private-options.h"
+
/* {Run time control of the debugging evaluator}
*/
@@ -59,10 +62,10 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
scm_dynwind_begin (0);
scm_dynwind_critical_section (SCM_BOOL_F);
- ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
+ ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
{
- scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
+ scm_options (ans, scm_debug_opts, FUNC_NAME);
SCM_OUT_OF_RANGE (1, setting);
}
SCM_RESET_DEBUG_MODE;
@@ -74,6 +77,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
}
#undef FUNC_NAME
+
static void
with_traps_before (void *data)
{
@@ -112,7 +116,6 @@ SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
#undef FUNC_NAME
-
SCM_SYMBOL (scm_sym_procname, "procname");
SCM_SYMBOL (scm_sym_dots, "...");
SCM_SYMBOL (scm_sym_source, "source");
@@ -526,7 +529,7 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
void
scm_init_debug ()
{
- scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
+ scm_init_opts (scm_debug_options, scm_debug_opts);
scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
scm_set_smob_print (scm_tc16_memoized, memoized_print);
diff --git a/libguile/debug.h b/libguile/debug.h
index c292004a3..79afa4d53 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -42,28 +42,13 @@
/* scm_debug_opts is defined in eval.c.
*/
-SCM_API scm_t_option scm_debug_opts[];
-
-#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
-#define SCM_TRACE_P scm_debug_opts[2].val
-#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
-#define SCM_BACKWARDS_P scm_debug_opts[4].val
-#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val
-#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val
-#define SCM_N_FRAMES scm_debug_opts[7].val
-#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val
-#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val
-#define SCM_BACKTRACE_P scm_debug_opts[10].val
-#define SCM_DEVAL_P scm_debug_opts[11].val
-#define SCM_STACK_LIMIT scm_debug_opts[12].val
-#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val
-#define SCM_WARN_DEPRECATED scm_debug_opts[14].val
-#define SCM_N_DEBUG_OPTIONS 15
+
SCM_API int scm_debug_mode_p;
SCM_API int scm_check_entry_p;
SCM_API int scm_check_apply_p;
SCM_API int scm_check_exit_p;
+SCM_API int scm_check_memoize_p;
#define SCM_RESET_DEBUG_MODE \
do {\
@@ -73,8 +58,10 @@ do {\
&& scm_is_true (SCM_APPLY_FRAME_HDLR);\
scm_check_exit_p = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\
&& scm_is_true (SCM_EXIT_FRAME_HDLR);\
+ scm_check_memoize_p = (SCM_MEMOIZE_P)\
+ && scm_is_true (SCM_MEMOIZE_HDLR);\
scm_debug_mode_p = SCM_DEVAL_P\
- || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
+ || scm_check_memoize_p || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
} while (0)
/* {Evaluator}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index bbd8bc07a..9a0862c3e 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
-/* Copyright (C) 2003,2004, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -164,7 +164,7 @@ SCM_API SCM scm_make_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf);
-extern SCM scm_create_hook (const char* name, int n_args);
+SCM_API SCM scm_create_hook (const char* name, int n_args);
#define SCM_LIST0 SCM_EOL
#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 6e314ddd9..22073033e 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -31,6 +31,9 @@
#include "libguile/strings.h"
#include "libguile/ports.h"
+#include "libguile/private-options.h"
+
+
/* Windows defines. */
#ifdef __MINGW32__
#define vsnprintf _vsnprintf
diff --git a/libguile/eq.c b/libguile/eq.c
index 7c7e76d0e..ebc91c93b 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -36,6 +36,9 @@
#include "libguile/validate.h"
#include "libguile/eq.h"
+
+#include "libguile/private-options.h"
+
#ifdef HAVE_STRING_H
diff --git a/libguile/eval.c b/libguile/eval.c
index dcbd1ac7d..95dd95974 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -20,12 +20,6 @@
#define _GNU_SOURCE
-/* This file is read twice in order to produce debugging versions of ceval and
- * scm_apply. These functions, deval and scm_dapply, are produced when we
- * define the preprocessor macro DEVAL. The file is divided into sections
- * which are treated differently with respect to DEVAL. The heads of these
- * sections are marked with the string "SECTION:". */
-
/* SECTION: This code is compiled once.
*/
@@ -35,8 +29,6 @@
#include "libguile/__scm.h"
-#ifndef DEVAL
-
/* This blob per the Autoconf manual (under "Particular Functions"). */
#if HAVE_ALLOCA_H
# include <alloca.h>
@@ -90,14 +82,18 @@ void *alloca (size_t);
#include "libguile/vectors.h"
#include "libguile/eval.h"
+#include "libguile/private-options.h"
+
static SCM unmemoize_exprs (SCM expr, SCM env);
static SCM canonicalize_define (SCM expr);
static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
static SCM unmemoize_builtin_macro (SCM expr, SCM env);
-static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
+static void ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
+static SCM ceval (SCM x, SCM env);
+static SCM deval (SCM x, SCM env);
@@ -1235,7 +1231,7 @@ scm_m_define (SCM expr, SCM env)
SCM tmp = value;
while (SCM_MACROP (tmp))
tmp = SCM_MACRO_CODE (tmp);
- if (SCM_CLOSUREP (tmp)
+ if (scm_is_true (scm_procedure_p (tmp))
/* Only the first definition determines the name. */
&& scm_is_false (scm_procedure_property (tmp, scm_sym_name)))
scm_set_procedure_property_x (tmp, scm_sym_name, variable);
@@ -2555,6 +2551,7 @@ scm_unmemocar (SCM form, SCM env)
SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
+SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol, "memoize-symbol");
SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
SCM_SYMBOL (sym_instead, "instead");
@@ -2581,46 +2578,27 @@ scm_badargsp (SCM formals, SCM args)
-/* The evaluator contains a plethora of EVAL symbols. This is an attempt at
- * explanation.
+/* The evaluator contains a plethora of EVAL symbols.
*
- * The following macros should be used in code which is read twice (where the
- * choice of evaluator is hard soldered):
*
- * CEVAL is the symbol used within one evaluator to call itself.
- * Originally, it is defined to ceval, but is redefined to deval during the
- * second pass.
- *
* SCM_I_EVALIM is used when it is known that the expression is an
* immediate. (This macro never calls an evaluator.)
*
- * EVAL evaluates an expression that is expected to have its symbols already
+ * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
* memoized. Expressions that are not of the form '(<form> <form> ...)' are
* evaluated inline without calling an evaluator.
*
- * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
+ * This macro uses ceval or deval depending on its 3rd argument.
+ *
+ * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
* potentially replacing a symbol at the position Y:<form> by its memoized
* variable. If Y:<form> is not of the form '(<form> <form> ...)', the
* evaluation is performed inline without calling an evaluator.
*
- * The following macros should be used in code which is read once
- * (where the choice of evaluator is dynamic):
+ * This macro uses ceval or deval depending on its 3rd argument.
*
- * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
- * debugging mode.
- *
- * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
- * on the debugging mode.
- *
- * The main motivation for keeping this plethora is efficiency
- * together with maintainability (=> locality of code).
*/
-static SCM ceval (SCM x, SCM env);
-static SCM deval (SCM x, SCM env);
-#define CEVAL ceval
-
-
#define SCM_I_EVALIM2(x) \
((scm_is_eq ((x), SCM_EOL) \
? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
@@ -2631,50 +2609,30 @@ static SCM deval (SCM x, SCM env);
? *scm_ilookup ((x), (env)) \
: SCM_I_EVALIM2(x))
-#define SCM_I_XEVAL(x, env) \
+#define SCM_I_XEVAL(x, env, debug_p) \
(SCM_IMP (x) \
? SCM_I_EVALIM2 (x) \
: (SCM_VARIABLEP (x) \
? SCM_VARIABLE_REF (x) \
: (scm_is_pair (x) \
- ? (scm_debug_mode_p \
+ ? (debug_p \
? deval ((x), (env)) \
: ceval ((x), (env))) \
: (x))))
-#define SCM_I_XEVALCAR(x, env) \
+#define SCM_I_XEVALCAR(x, env, debug_p) \
(SCM_IMP (SCM_CAR (x)) \
? SCM_I_EVALIM (SCM_CAR (x), (env)) \
: (SCM_VARIABLEP (SCM_CAR (x)) \
? SCM_VARIABLE_REF (SCM_CAR (x)) \
: (scm_is_pair (SCM_CAR (x)) \
- ? (scm_debug_mode_p \
+ ? (debug_p \
? deval (SCM_CAR (x), (env)) \
: ceval (SCM_CAR (x), (env))) \
: (!scm_is_symbol (SCM_CAR (x)) \
? SCM_CAR (x) \
: *scm_lookupcar ((x), (env), 1)))))
-#define EVAL(x, env) \
- (SCM_IMP (x) \
- ? SCM_I_EVALIM ((x), (env)) \
- : (SCM_VARIABLEP (x) \
- ? SCM_VARIABLE_REF (x) \
- : (scm_is_pair (x) \
- ? CEVAL ((x), (env)) \
- : (x))))
-
-#define EVALCAR(x, env) \
- (SCM_IMP (SCM_CAR (x)) \
- ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
- : (SCM_VARIABLEP (SCM_CAR (x)) \
- ? SCM_VARIABLE_REF (SCM_CAR (x)) \
- : (scm_is_pair (SCM_CAR (x)) \
- ? CEVAL (SCM_CAR (x), (env)) \
- : (!scm_is_symbol (SCM_CAR (x)) \
- ? SCM_CAR (x) \
- : *scm_lookupcar ((x), (env), 1)))))
-
scm_i_pthread_mutex_t source_mutex;
@@ -2935,25 +2893,7 @@ lazy_memoize_variable (const SCM symbol, const SCM environment)
SCM
scm_eval_car (SCM pair, SCM env)
{
- return SCM_I_XEVALCAR (pair, env);
-}
-
-
-SCM
-scm_eval_args (SCM l, SCM env, SCM proc)
-{
- SCM results = SCM_EOL, *lloc = &results, res;
- while (scm_is_pair (l))
- {
- res = EVALCAR (l, env);
-
- *lloc = scm_list_1 (res);
- lloc = SCM_CDRLOC (*lloc);
- l = SCM_CDR (l);
- }
- if (!scm_is_null (l))
- scm_wrong_num_args (proc);
- return results;
+ return SCM_I_XEVALCAR (pair, env, scm_debug_mode_p);
}
@@ -2980,70 +2920,13 @@ scm_eval_body (SCM code, SCM env)
}
}
else
- SCM_I_XEVAL (SCM_CAR (code), env);
+ SCM_I_XEVAL (SCM_CAR (code), env, scm_debug_mode_p);
code = next;
next = SCM_CDR (code);
}
- return SCM_I_XEVALCAR (code, env);
+ return SCM_I_XEVALCAR (code, env, scm_debug_mode_p);
}
-#endif /* !DEVAL */
-
-
-/* SECTION: This code is specific for the debugging support. One
- * branch is read when DEVAL isn't defined, the other when DEVAL is
- * defined.
- */
-
-#ifndef DEVAL
-
-#define SCM_APPLY scm_apply
-#define PREP_APPLY(proc, args)
-#define ENTER_APPLY
-#define RETURN(x) do { return x; } while (0)
-#ifdef STACK_CHECKING
-#ifndef NO_CEVAL_STACK_CHECKING
-#define EVAL_STACK_CHECKING
-#endif
-#endif
-
-#else /* !DEVAL */
-
-#undef CEVAL
-#define CEVAL deval /* Substitute all uses of ceval */
-
-#undef SCM_APPLY
-#define SCM_APPLY scm_dapply
-
-#undef PREP_APPLY
-#define PREP_APPLY(p, l) \
-{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
-
-#undef ENTER_APPLY
-#define ENTER_APPLY \
-do { \
- SCM_SET_ARGSREADY (debug);\
- if (scm_check_apply_p && SCM_TRAPS_P)\
- if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
- {\
- SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
- SCM_SET_TRACED_FRAME (debug); \
- SCM_TRAPS_P = 0;\
- tmp = scm_make_debugobj (&debug);\
- scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
- SCM_TRAPS_P = 1;\
- }\
-} while (0)
-
-#undef RETURN
-#define RETURN(e) do { proc = (e); goto exit; } while (0)
-
-#ifdef STACK_CHECKING
-#ifndef EVAL_STACK_CHECKING
-#define EVAL_STACK_CHECKING
-#endif
-#endif
-
/* scm_last_debug_frame contains a pointer to the last debugging information
* stack frame. It is accessed very often from the debugging evaluator, so it
@@ -3061,11 +2944,13 @@ int scm_debug_mode_p;
int scm_check_entry_p;
int scm_check_apply_p;
int scm_check_exit_p;
+int scm_check_memoize_p;
long scm_eval_stack;
scm_t_option scm_eval_opts[] = {
- { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
+ { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
+ { 0 }
};
scm_t_option scm_debug_opts[] = {
@@ -3086,11 +2971,22 @@ scm_t_option scm_debug_opts[] = {
{ SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
{ SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
{ SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
+
{ SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
- { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."},
- { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." }
+ { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
+ "Show file names and line numbers "
+ "in backtraces when not `#f'. A value of `base' "
+ "displays only base names, while `#t' displays full names."},
+ { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
+ "Warn when deprecated features are used." },
+ { 0 },
};
+
+/*
+ * this ordering is awkward and illogical, but we maintain it for
+ * compatibility. --hwn
+ */
scm_t_option scm_evaluator_trap_table[] = {
{ SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
{ SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
@@ -3098,9 +2994,13 @@ scm_t_option scm_evaluator_trap_table[] = {
{ SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
{ SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
{ SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
- { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }
+ { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." },
+ { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." },
+ { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." },
+ { 0 }
};
+
SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
(SCM setting),
"Option interface for the evaluation options. Instead of using\n"
@@ -3114,7 +3014,6 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
scm_dynwind_critical_section (SCM_BOOL_F);
ans = scm_options (setting,
scm_eval_opts,
- SCM_N_EVAL_OPTIONS,
FUNC_NAME);
scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
scm_dynwind_end ();
@@ -3130,11 +3029,16 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
#define FUNC_NAME s_scm_evaluator_traps
{
SCM ans;
+
+
+ scm_options_try (setting,
+ scm_evaluator_trap_table,
+ FUNC_NAME, 1);
SCM_CRITICAL_SECTION_START;
ans = scm_options (setting,
scm_evaluator_trap_table,
- SCM_N_EVALUATOR_TRAPS,
FUNC_NAME);
+
/* njrev: same again. */
SCM_RESET_DEBUG_MODE;
SCM_CRITICAL_SECTION_END;
@@ -3143,1502 +3047,6 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
#undef FUNC_NAME
-static SCM
-deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
-{
- SCM *results = lloc;
- while (scm_is_pair (l))
- {
- const SCM res = EVALCAR (l, env);
-
- *lloc = scm_list_1 (res);
- lloc = SCM_CDRLOC (*lloc);
- l = SCM_CDR (l);
- }
- if (!scm_is_null (l))
- scm_wrong_num_args (proc);
- return *results;
-}
-
-static void
-eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
-{
- SCM argv[10];
- int i = 0, imax = sizeof (argv) / sizeof (SCM);
-
- while (!scm_is_null (init_forms))
- {
- if (imax == i)
- {
- eval_letrec_inits (env, init_forms, init_values_eol);
- break;
- }
- argv[i++] = EVALCAR (init_forms, env);
- init_forms = SCM_CDR (init_forms);
- }
-
- for (i--; i >= 0; i--)
- {
- **init_values_eol = scm_list_1 (argv[i]);
- *init_values_eol = SCM_CDRLOC (**init_values_eol);
- }
-}
-
-#endif /* !DEVAL */
-
-
-/* SECTION: This code is compiled twice.
- */
-
-
-/* Update the toplevel environment frame ENV so that it refers to the
- * current module. */
-#define UPDATE_TOPLEVEL_ENV(env) \
- do { \
- SCM p = scm_current_module_lookup_closure (); \
- if (p != SCM_CAR (env)) \
- env = scm_top_level_env (p); \
- } while (0)
-
-
-#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
- ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
-
-
-/* This is the evaluator. Like any real monster, it has three heads:
- *
- * ceval is the non-debugging evaluator, deval is the debugging version. Both
- * are implemented using a common code base, using the following mechanism:
- * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
- * is no function CEVAL, but the code for CEVAL actually compiles to either
- * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
- * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
- * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
- * are enclosed within #ifdef DEVAL ... #endif.
- *
- * All three (ceval, deval and their common implementation CEVAL) take two
- * input parameters, x and env: x is a single expression to be evalutated.
- * env is the environment in which bindings are searched.
- *
- * x is known to be a pair. Since x is a single expression, it is necessarily
- * in a tail position. If x is just a call to another function like in the
- * expression (foo exp1 exp2 ...), the realization of that call therefore
- * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
- * however, may do so). This is realized by making extensive use of 'goto'
- * statements within the evaluator: The gotos replace recursive calls to
- * CEVAL, thus re-using the same stack frame that CEVAL was already using.
- * If, however, x represents some form that requires to evaluate a sequence of
- * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
- * performed for all but the last expression of that sequence. */
-
-static SCM
-CEVAL (SCM x, SCM env)
-{
- SCM proc, arg1;
-#ifdef DEVAL
- scm_t_debug_frame debug;
- scm_t_debug_info *debug_info_end;
- debug.prev = scm_i_last_debug_frame ();
- debug.status = 0;
- /*
- * The debug.vect contains twice as much scm_t_debug_info frames as the
- * user has specified with (debug-set! frames <n>).
- *
- * Even frames are eval frames, odd frames are apply frames.
- */
- debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
- * sizeof (scm_t_debug_info));
- debug.info = debug.vect;
- debug_info_end = debug.vect + scm_debug_eframe_size;
- scm_i_set_last_debug_frame (&debug);
-#endif
-#ifdef EVAL_STACK_CHECKING
- if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
- {
-#ifdef DEVAL
- debug.info->e.exp = x;
- debug.info->e.env = env;
-#endif
- scm_report_stack_overflow ();
- }
-#endif
-
-#ifdef DEVAL
- goto start;
-#endif
-
-loop:
-#ifdef DEVAL
- SCM_CLEAR_ARGSREADY (debug);
- if (SCM_OVERFLOWP (debug))
- --debug.info;
- /*
- * In theory, this should be the only place where it is necessary to
- * check for space in debug.vect since both eval frames and
- * available space are even.
- *
- * For this to be the case, however, it is necessary that primitive
- * special forms which jump back to `loop', `begin' or some similar
- * label call PREP_APPLY.
- */
- else if (++debug.info >= debug_info_end)
- {
- SCM_SET_OVERFLOW (debug);
- debug.info -= 2;
- }
-
-start:
- debug.info->e.exp = x;
- debug.info->e.env = env;
- if (scm_check_entry_p && SCM_TRAPS_P)
- {
- if (SCM_ENTER_FRAME_P
- || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
- {
- SCM stackrep;
- SCM tail = scm_from_bool (SCM_TAILRECP (debug));
- SCM_SET_TAILREC (debug);
- stackrep = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
- scm_sym_enter_frame,
- stackrep,
- tail,
- unmemoize_expression (x, env));
- SCM_TRAPS_P = 1;
- if (scm_is_pair (stackrep) &&
- scm_is_eq (SCM_CAR (stackrep), sym_instead))
- {
- /* This gives the possibility for the debugger to modify
- the source expression before evaluation. */
- x = SCM_CDR (stackrep);
- if (SCM_IMP (x))
- RETURN (x);
- }
- }
- }
-#endif
-dispatch:
- SCM_TICK;
- if (SCM_ISYMP (SCM_CAR (x)))
- {
- switch (ISYMNUM (SCM_CAR (x)))
- {
- case (ISYMNUM (SCM_IM_AND)):
- x = SCM_CDR (x);
- while (!scm_is_null (SCM_CDR (x)))
- {
- SCM test_result = EVALCAR (x, env);
- if (scm_is_false (test_result) || SCM_NILP (test_result))
- RETURN (SCM_BOOL_F);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
- case (ISYMNUM (SCM_IM_BEGIN)):
- x = SCM_CDR (x);
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
-
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
-
- begin:
- /* If we are on toplevel with a lookup closure, we need to sync
- with the current module. */
- if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
- {
- UPDATE_TOPLEVEL_ENV (env);
- while (!scm_is_null (SCM_CDR (x)))
- {
- EVALCAR (x, env);
- UPDATE_TOPLEVEL_ENV (env);
- x = SCM_CDR (x);
- }
- goto carloop;
- }
- else
- goto nontoplevel_begin;
-
- nontoplevel_begin:
- while (!scm_is_null (SCM_CDR (x)))
- {
- const SCM form = SCM_CAR (x);
- if (SCM_IMP (form))
- {
- if (SCM_ISYMP (form))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (x)))
- m_expand_body (x, env);
- scm_dynwind_end ();
- goto nontoplevel_begin;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
- }
- else
- (void) EVAL (form, env);
- x = SCM_CDR (x);
- }
-
- carloop:
- {
- /* scm_eval last form in list */
- const SCM last_form = SCM_CAR (x);
-
- if (scm_is_pair (last_form))
- {
- /* This is by far the most frequent case. */
- x = last_form;
- goto loop; /* tail recurse */
- }
- else if (SCM_IMP (last_form))
- RETURN (SCM_I_EVALIM (last_form, env));
- else if (SCM_VARIABLEP (last_form))
- RETURN (SCM_VARIABLE_REF (last_form));
- else if (scm_is_symbol (last_form))
- RETURN (*scm_lookupcar (x, env, 1));
- else
- RETURN (last_form);
- }
-
-
- case (ISYMNUM (SCM_IM_CASE)):
- x = SCM_CDR (x);
- {
- const SCM key = EVALCAR (x, env);
- x = SCM_CDR (x);
- while (!scm_is_null (x))
- {
- const SCM clause = SCM_CAR (x);
- SCM labels = SCM_CAR (clause);
- if (scm_is_eq (labels, SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- while (!scm_is_null (labels))
- {
- const SCM label = SCM_CAR (labels);
- if (scm_is_eq (label, key)
- || scm_is_true (scm_eqv_p (label, key)))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- labels = SCM_CDR (labels);
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_COND)):
- x = SCM_CDR (x);
- while (!scm_is_null (x))
- {
- const SCM clause = SCM_CAR (x);
- if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- arg1 = EVALCAR (clause, env);
- /* SRFI 61 extended cond */
- if (!scm_is_null (SCM_CDR (clause))
- && !scm_is_null (SCM_CDDR (clause))
- && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
- {
- SCM xx, guard_result;
- if (SCM_VALUESP (arg1))
- arg1 = scm_struct_ref (arg1, SCM_INUM0);
- else
- arg1 = scm_list_1 (arg1);
- xx = SCM_CDR (clause);
- proc = EVALCAR (xx, env);
- guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
- if (scm_is_true (guard_result)
- && !SCM_NILP (guard_result))
- {
- proc = SCM_CDDR (xx);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
- }
- else if (scm_is_true (arg1) && !SCM_NILP (arg1))
- {
- x = SCM_CDR (clause);
- if (scm_is_null (x))
- RETURN (arg1);
- else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
- {
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, scm_list_1 (arg1));
- ENTER_APPLY;
- goto evap1;
- }
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_DO)):
- x = SCM_CDR (x);
- {
- /* Compute the initialization values and the initial environment. */
- SCM init_forms = SCM_CAR (x);
- SCM init_values = SCM_EOL;
- while (!scm_is_null (init_forms))
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDR (x);
- {
- SCM test_form = SCM_CAR (x);
- SCM body_forms = SCM_CADR (x);
- SCM step_forms = SCM_CDDR (x);
-
- SCM test_result = EVALCAR (test_form, env);
-
- while (scm_is_false (test_result) || SCM_NILP (test_result))
- {
- {
- /* Evaluate body forms. */
- SCM temp_forms;
- for (temp_forms = body_forms;
- !scm_is_null (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- SCM form = SCM_CAR (temp_forms);
- /* Dirk:FIXME: We only need to eval forms that may have
- * a side effect here. This is only true for forms that
- * start with a pair. All others are just constants.
- * Since with the current memoizer 'form' may hold a
- * constant, we call EVAL here to handle the constant
- * cases. In the long run it would make sense to have
- * the macro transformer of 'do' eliminate all forms
- * that have no sideeffect. Then instead of EVAL we
- * could call CEVAL directly here. */
- (void) EVAL (form, env);
- }
- }
-
- {
- /* Evaluate the step expressions. */
- SCM temp_forms;
- SCM step_values = SCM_EOL;
- for (temp_forms = step_forms;
- !scm_is_null (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- const SCM value = EVALCAR (temp_forms, env);
- step_values = scm_cons (value, step_values);
- }
- env = SCM_EXTEND_ENV (SCM_CAAR (env),
- step_values,
- SCM_CDR (env));
- }
-
- test_result = EVALCAR (test_form, env);
- }
- }
- x = SCM_CDAR (x);
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_IF)):
- x = SCM_CDR (x);
- {
- SCM test_result = EVALCAR (x, env);
- x = SCM_CDR (x); /* then expression */
- if (scm_is_false (test_result) || SCM_NILP (test_result))
- {
- x = SCM_CDR (x); /* else expression */
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
- }
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
-
- case (ISYMNUM (SCM_IM_LET)):
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CADR (x);
- SCM init_values = SCM_EOL;
- do
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- while (!scm_is_null (init_forms));
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_LETREC)):
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CAR (x);
- SCM init_values = scm_list_1 (SCM_BOOL_T);
- SCM *init_values_eol = SCM_CDRLOC (init_values);
- eval_letrec_inits (env, init_forms, &init_values_eol);
- SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_LETSTAR)):
- x = SCM_CDR (x);
- {
- SCM bindings = SCM_CAR (x);
- if (!scm_is_null (bindings))
- {
- do
- {
- SCM name = SCM_CAR (bindings);
- SCM init = SCM_CDR (bindings);
- env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
- bindings = SCM_CDR (init);
- }
- while (!scm_is_null (bindings));
- }
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_OR)):
- x = SCM_CDR (x);
- while (!scm_is_null (SCM_CDR (x)))
- {
- SCM val = EVALCAR (x, env);
- if (scm_is_true (val) && !SCM_NILP (val))
- RETURN (val);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
-
- case (ISYMNUM (SCM_IM_LAMBDA)):
- RETURN (scm_closure (SCM_CDR (x), env));
-
-
- case (ISYMNUM (SCM_IM_QUOTE)):
- RETURN (SCM_CDR (x));
-
-
- case (ISYMNUM (SCM_IM_SET_X)):
- x = SCM_CDR (x);
- {
- SCM *location;
- SCM variable = SCM_CAR (x);
- if (SCM_ILOCP (variable))
- location = scm_ilookup (variable, env);
- else if (SCM_VARIABLEP (variable))
- location = SCM_VARIABLE_LOC (variable);
- else
- {
- /* (scm_is_symbol (variable)) is known to be true */
- variable = lazy_memoize_variable (variable, env);
- SCM_SETCAR (x, variable);
- location = SCM_VARIABLE_LOC (variable);
- }
- x = SCM_CDR (x);
- *location = EVALCAR (x, env);
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_APPLY)):
- /* Evaluate the procedure to be applied. */
- x = SCM_CDR (x);
- proc = EVALCAR (x, env);
- PREP_APPLY (proc, SCM_EOL);
-
- /* Evaluate the argument holding the list of arguments */
- x = SCM_CDR (x);
- arg1 = EVALCAR (x, env);
-
- apply_proc:
- /* Go here to tail-apply a procedure. PROC is the procedure and
- * ARG1 is the list of arguments. PREP_APPLY must have been called
- * before jumping to apply_proc. */
- if (SCM_CLOSUREP (proc))
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
-#ifdef DEVAL
- debug.info->a.args = arg1;
-#endif
- if (scm_badargsp (formals, arg1))
- scm_wrong_num_args (proc);
- ENTER_APPLY;
- /* Copy argument list */
- if (SCM_NULL_OR_NIL_P (arg1))
- env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- else
- {
- SCM args = scm_list_1 (SCM_CAR (arg1));
- SCM tail = args;
- arg1 = SCM_CDR (arg1);
- while (!SCM_NULL_OR_NIL_P (arg1))
- {
- SCM new_tail = scm_list_1 (SCM_CAR (arg1));
- SCM_SETCDR (tail, new_tail);
- tail = new_tail;
- arg1 = SCM_CDR (arg1);
- }
- env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
- }
-
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
- else
- {
- ENTER_APPLY;
- RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
- }
-
-
- case (ISYMNUM (SCM_IM_CONT)):
- {
- int first;
- SCM val = scm_make_continuation (&first);
-
- if (!first)
- RETURN (val);
- else
- {
- arg1 = val;
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, scm_list_1 (arg1));
- ENTER_APPLY;
- goto evap1;
- }
- }
-
-
- case (ISYMNUM (SCM_IM_DELAY)):
- RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
-
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- case (ISYMNUM (SCM_IM_FUTURE)):
- RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
-#endif
-
- /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
- code (type_dispatch) is intended to be the tail of the case
- clause for the internal macro SCM_IM_DISPATCH. Please don't
- remove it from this location without discussing it with Mikael
- <djurfeldt@nada.kth.se> */
-
- /* The type dispatch code is duplicated below
- * (c.f. objects.c:scm_mcache_compute_cmethod) since that
- * cuts down execution time for type dispatch to 50%. */
- type_dispatch: /* inputs: x, arg1 */
- /* Type dispatch means to determine from the types of the function
- * arguments (i. e. the 'signature' of the call), which method from
- * a generic function is to be called. This process of selecting
- * the right method takes some time. To speed it up, guile uses
- * caching: Together with the macro call to dispatch the signatures
- * of some previous calls to that generic function from the same
- * place are stored (in the code!) in a cache that we call the
- * 'method cache'. This is done since it is likely, that
- * consecutive calls to dispatch from that position in the code will
- * have the same signature. Thus, the type dispatch works as
- * follows: First, determine a hash value from the signature of the
- * actual arguments. Second, use this hash value as an index to
- * find that same signature in the method cache stored at this
- * position in the code. If found, you have also found the
- * corresponding method that belongs to that signature. If the
- * signature is not found in the method cache, you have to perform a
- * full search over all signatures stored with the generic
- * function. */
- {
- unsigned long int specializers;
- unsigned long int hash_value;
- unsigned long int cache_end_pos;
- unsigned long int mask;
- SCM method_cache;
-
- {
- SCM z = SCM_CDDR (x);
- SCM tmp = SCM_CADR (z);
- specializers = scm_to_ulong (SCM_CAR (z));
-
- /* Compute a hash value for searching the method cache. There
- * are two variants for computing the hash value, a (rather)
- * complicated one, and a simple one. For the complicated one
- * explained below, tmp holds a number that is used in the
- * computation. */
- if (scm_is_simple_vector (tmp))
- {
- /* This method of determining the hash value is much
- * simpler: Set the hash value to zero and just perform a
- * linear search through the method cache. */
- method_cache = tmp;
- mask = (unsigned long int) ((long) -1);
- hash_value = 0;
- cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache);
- }
- else
- {
- /* Use the signature of the actual arguments to determine
- * the hash value. This is done as follows: Each class has
- * an array of random numbers, that are determined when the
- * class is created. The integer 'hashset' is an index into
- * that array of random numbers. Now, from all classes that
- * are part of the signature of the actual arguments, the
- * random numbers at index 'hashset' are taken and summed
- * up, giving the hash value. The value of 'hashset' is
- * stored at the call to dispatch. This allows to have
- * different 'formulas' for calculating the hash value at
- * different places where dispatch is called. This allows
- * to optimize the hash formula at every individual place
- * where dispatch is called, such that hopefully the hash
- * value that is computed will directly point to the right
- * method in the method cache. */
- unsigned long int hashset = scm_to_ulong (tmp);
- unsigned long int counter = specializers + 1;
- SCM tmp_arg = arg1;
- hash_value = 0;
- while (!scm_is_null (tmp_arg) && counter != 0)
- {
- SCM class = scm_class_of (SCM_CAR (tmp_arg));
- hash_value += SCM_INSTANCE_HASH (class, hashset);
- tmp_arg = SCM_CDR (tmp_arg);
- counter--;
- }
- z = SCM_CDDR (z);
- method_cache = SCM_CADR (z);
- mask = scm_to_ulong (SCM_CAR (z));
- hash_value &= mask;
- cache_end_pos = hash_value;
- }
- }
-
- {
- /* Search the method cache for a method with a matching
- * signature. Start the search at position 'hash_value'. The
- * hashing implementation uses linear probing for conflict
- * resolution, that is, if the signature in question is not
- * found at the starting index in the hash table, the next table
- * entry is tried, and so on, until in the worst case the whole
- * cache has been searched, but still the signature has not been
- * found. */
- SCM z;
- do
- {
- SCM args = arg1; /* list of arguments */
- z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value);
- while (!scm_is_null (args))
- {
- /* More arguments than specifiers => CLASS != ENV */
- SCM class_of_arg = scm_class_of (SCM_CAR (args));
- if (!scm_is_eq (class_of_arg, SCM_CAR (z)))
- goto next_method;
- args = SCM_CDR (args);
- z = SCM_CDR (z);
- }
- /* Fewer arguments than specifiers => CAR != ENV */
- if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
- goto apply_cmethod;
- next_method:
- hash_value = (hash_value + 1) & mask;
- } while (hash_value != cache_end_pos);
-
- /* No appropriate method was found in the cache. */
- z = scm_memoize_method (x, arg1);
-
- apply_cmethod: /* inputs: z, arg1 */
- {
- SCM formals = SCM_CMETHOD_FORMALS (z);
- env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
- x = SCM_CMETHOD_BODY (z);
- goto nontoplevel_begin;
- }
- }
- }
-
-
- case (ISYMNUM (SCM_IM_SLOT_REF)):
- x = SCM_CDR (x);
- {
- SCM instance = EVALCAR (x, env);
- unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
- RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
- }
-
-
- case (ISYMNUM (SCM_IM_SLOT_SET_X)):
- x = SCM_CDR (x);
- {
- SCM instance = EVALCAR (x, env);
- unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
- SCM value = EVALCAR (SCM_CDDR (x), env);
- SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
- RETURN (SCM_UNSPECIFIED);
- }
-
-
-#if SCM_ENABLE_ELISP
-
- case (ISYMNUM (SCM_IM_NIL_COND)):
- {
- SCM test_form = SCM_CDR (x);
- x = SCM_CDR (test_form);
- while (!SCM_NULL_OR_NIL_P (x))
- {
- SCM test_result = EVALCAR (test_form, env);
- if (!(scm_is_false (test_result)
- || SCM_NULL_OR_NIL_P (test_result)))
- {
- if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
- RETURN (test_result);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
- else
- {
- test_form = SCM_CDR (x);
- x = SCM_CDR (test_form);
- }
- }
- x = test_form;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
-
-#endif /* SCM_ENABLE_ELISP */
-
- case (ISYMNUM (SCM_IM_BIND)):
- {
- SCM vars, exps, vals;
-
- x = SCM_CDR (x);
- vars = SCM_CAAR (x);
- exps = SCM_CDAR (x);
- vals = SCM_EOL;
- while (!scm_is_null (exps))
- {
- vals = scm_cons (EVALCAR (exps, env), vals);
- exps = SCM_CDR (exps);
- }
-
- scm_swap_bindings (vars, vals);
- scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
-
- /* Ignore all but the last evaluation result. */
- for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
- {
- if (scm_is_pair (SCM_CAR (x)))
- CEVAL (SCM_CAR (x), env);
- }
- proc = EVALCAR (x, env);
-
- scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
- scm_swap_bindings (vars, vals);
-
- RETURN (proc);
- }
-
-
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
- {
- SCM producer;
-
- x = SCM_CDR (x);
- producer = EVALCAR (x, env);
- x = SCM_CDR (x);
- proc = EVALCAR (x, env); /* proc is the consumer. */
- arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
- if (SCM_VALUESP (arg1))
- {
- /* The list of arguments is not copied. Rather, it is assumed
- * that this has been done by the 'values' procedure. */
- arg1 = scm_struct_ref (arg1, SCM_INUM0);
- }
- else
- {
- arg1 = scm_list_1 (arg1);
- }
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
-
-
- default:
- break;
- }
- }
- else
- {
- if (SCM_VARIABLEP (SCM_CAR (x)))
- proc = SCM_VARIABLE_REF (SCM_CAR (x));
- else if (SCM_ILOCP (SCM_CAR (x)))
- proc = *scm_ilookup (SCM_CAR (x), env);
- else if (scm_is_pair (SCM_CAR (x)))
- proc = CEVAL (SCM_CAR (x), env);
- else if (scm_is_symbol (SCM_CAR (x)))
- {
- SCM orig_sym = SCM_CAR (x);
- {
- SCM *location = scm_lookupcar1 (x, env, 1);
- if (location == NULL)
- {
- /* we have lost the race, start again. */
- goto dispatch;
- }
- proc = *location;
- }
-
- if (SCM_MACROP (proc))
- {
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
- lookupcar */
- handle_a_macro: /* inputs: x, env, proc */
-#ifdef DEVAL
- /* Set a flag during macro expansion so that macro
- application frames can be deleted from the backtrace. */
- SCM_SET_MACROEXP (debug);
-#endif
- arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
- scm_cons (env, scm_listofnull));
-#ifdef DEVAL
- SCM_CLEAR_MACROEXP (debug);
-#endif
- switch (SCM_MACRO_TYPE (proc))
- {
- case 3:
- case 2:
- if (!scm_is_pair (arg1))
- arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
-
- assert (!scm_is_eq (x, SCM_CAR (arg1))
- && !scm_is_eq (x, SCM_CDR (arg1)));
-
-#ifdef DEVAL
- if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
- {
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (arg1));
- SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_CRITICAL_SECTION_END;
- goto dispatch;
- }
- /* Prevent memoizing of debug info expression. */
- debug.info->e.exp = scm_cons_source (debug.info->e.exp,
- SCM_CAR (x),
- SCM_CDR (x));
-#endif
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (arg1));
- SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_CRITICAL_SECTION_END;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto loop;
-#if SCM_ENABLE_DEPRECATED == 1
- case 1:
- x = arg1;
- if (SCM_NIMP (x))
- {
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto loop;
- }
- else
- RETURN (arg1);
-#endif
- case 0:
- RETURN (arg1);
- }
- }
- }
- else
- proc = SCM_CAR (x);
-
- if (SCM_MACROP (proc))
- goto handle_a_macro;
- }
-
-
- /* When reaching this part of the code, the following is granted: Variable x
- * holds the first pair of an expression of the form (<function> arg ...).
- * Variable proc holds the object that resulted from the evaluation of
- * <function>. In the following, the arguments (if any) will be evaluated,
- * and proc will be applied to them. If proc does not really hold a
- * function object, this will be signalled as an error on the scheme
- * level. If the number of arguments does not match the number of arguments
- * that are allowed to be passed to proc, also an error on the scheme level
- * will be signalled. */
- PREP_APPLY (proc, SCM_EOL);
- if (scm_is_null (SCM_CDR (x))) {
- ENTER_APPLY;
- evap0:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* no arguments given */
- case scm_tc7_subr_0:
- RETURN (SCM_SUBRF (proc) ());
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (SCM_EOL));
- case scm_tc7_rpsubr:
- RETURN (SCM_BOOL_T);
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_0 (proc));
- case scm_tc7_cclo:
- arg1 = proc;
- proc = SCM_CCLO_SUBR (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
- debug.info->a.args = scm_list_1 (arg1);
-#endif
- goto evap1;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
-#endif
- if (!SCM_CLOSUREP (proc))
- goto evap0;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_pair (formals))
- goto wrongnumargs;
- x = SCM_CLOSURE_BODY (proc);
- env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- goto nontoplevel_begin;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
- arg1 = SCM_EOL;
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- {
- arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
-#ifdef DEVAL
- debug.info->a.proc = proc;
- debug.info->a.args = scm_list_1 (arg1);
-#endif
- goto evap1;
- }
- else
- goto badfun;
- case scm_tc7_subr_1:
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- wrongnumargs:
- scm_wrong_num_args (proc);
- default:
- badfun:
- scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
- }
- }
-
- /* must handle macros by here */
- x = SCM_CDR (x);
- if (scm_is_pair (x))
- arg1 = EVALCAR (x, env);
- else
- scm_wrong_num_args (proc);
-#ifdef DEVAL
- debug.info->a.args = scm_list_1 (arg1);
-#endif
- x = SCM_CDR (x);
- {
- SCM arg2;
- if (scm_is_null (x))
- {
- ENTER_APPLY;
- evap1: /* inputs: proc, arg1 */
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have one argument in arg1 */
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- case scm_tc7_subr_1:
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_dsubr:
- if (SCM_I_INUMP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1,
- scm_i_symbol_chars (SCM_SNAME (proc)));
- case scm_tc7_cxr:
- RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
- case scm_tc7_rpsubr:
- RETURN (SCM_BOOL_T);
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- case scm_tc7_lsubr:
-#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
-#else
- RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
-#endif
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
- case scm_tc7_cclo:
- arg2 = arg1;
- arg1 = proc;
- proc = SCM_CCLO_SUBR (proc);
-#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
- debug.info->a.proc = proc;
-#endif
- goto evap2;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
-#endif
- if (!SCM_CLOSUREP (proc))
- goto evap1;
- /* fallthrough */
- case scm_tcs_closures:
- {
- /* clos1: */
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
- goto wrongnumargs;
- x = SCM_CLOSURE_BODY (proc);
-#ifdef DEVAL
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
-#else
- env = SCM_EXTEND_ENV (formals,
- scm_list_1 (arg1),
- SCM_ENV (proc));
-#endif
- goto nontoplevel_begin;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_1 (arg1);
-#endif
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- {
- arg2 = arg1;
- arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
-#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
- debug.info->a.proc = proc;
-#endif
- goto evap2;
- }
- else
- goto badfun;
- case scm_tc7_subr_2:
- case scm_tc7_subr_0:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- }
- }
- if (scm_is_pair (x))
- arg2 = EVALCAR (x, env);
- else
- scm_wrong_num_args (proc);
-
- { /* have two or more arguments */
-#ifdef DEVAL
- debug.info->a.args = scm_list_2 (arg1, arg2);
-#endif
- x = SCM_CDR (x);
- if (scm_is_null (x)) {
- ENTER_APPLY;
- evap2:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have two arguments */
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, arg2));
- case scm_tc7_lsubr:
-#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
-#else
- RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
-#endif
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (arg1, arg2));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
- cclon:
- case scm_tc7_cclo:
-#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
-#else
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons2 (proc, arg1,
- scm_cons (arg2,
- scm_eval_args (x,
- env,
- proc))),
- SCM_EOL));
-#endif
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_2 (arg1, arg2);
-#endif
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- {
- operatorn:
-#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
-#else
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons2 (proc, arg1,
- scm_cons (arg2,
- scm_eval_args (x,
- env,
- proc))),
- SCM_EOL));
-#endif
- }
- else
- goto badfun;
- case scm_tc7_subr_0:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_1:
- case scm_tc7_subr_3:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.info->a.proc = proc;
-#endif
- if (!SCM_CLOSUREP (proc))
- goto evap2;
- /* fallthrough */
- case scm_tcs_closures:
- {
- /* clos2: */
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_is_pair (SCM_CDDR (formals))))))
- goto wrongnumargs;
-#ifdef DEVAL
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
-#else
- env = SCM_EXTEND_ENV (formals,
- scm_list_2 (arg1, arg2),
- SCM_ENV (proc));
-#endif
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
- }
- }
- if (!scm_is_pair (x))
- scm_wrong_num_args (proc);
-#ifdef DEVAL
- debug.info->a.args = scm_cons2 (arg1, arg2,
- deval_args (x, env, proc,
- SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
-#endif
- ENTER_APPLY;
- evap3:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have 3 or more arguments */
-#ifdef DEVAL
- case scm_tc7_subr_3:
- if (!scm_is_null (SCM_CDR (x)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CADDR (debug.info->a.args)));
- case scm_tc7_asubr:
- arg1 = SCM_SUBRF(proc)(arg1, arg2);
- arg2 = SCM_CDDR (debug.info->a.args);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
- arg2 = SCM_CDR (arg2);
- }
- while (SCM_NIMP (arg2));
- RETURN (arg1);
- case scm_tc7_rpsubr:
- if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- arg1 = SCM_CDDR (debug.info->a.args);
- do
- {
- if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
- RETURN (SCM_BOOL_F);
- arg2 = SCM_CAR (arg1);
- arg1 = SCM_CDR (arg1);
- }
- while (SCM_NIMP (arg1));
- RETURN (SCM_BOOL_T);
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CDDR (debug.info->a.args)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
- SCM_CDDR (debug.info->a.args)));
- case scm_tc7_cclo:
- goto cclon;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- debug.info->a.proc = proc;
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto wrongnumargs;
- SCM_SET_ARGSREADY (debug);
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
-#else /* DEVAL */
- case scm_tc7_subr_3:
- if (!scm_is_null (SCM_CDR (x)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
- case scm_tc7_asubr:
- arg1 = SCM_SUBRF (proc) (arg1, arg2);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- while (!scm_is_null (x));
- RETURN (arg1);
- case scm_tc7_rpsubr:
- if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- do
- {
- arg1 = EVALCAR (x, env);
- if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
- RETURN (SCM_BOOL_F);
- arg2 = arg1;
- x = SCM_CDR (x);
- }
- while (!scm_is_null (x));
- RETURN (SCM_BOOL_T);
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
- arg2,
- scm_eval_args (x, env, proc))));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
- scm_eval_args (x, env, proc)));
- case scm_tc7_cclo:
- goto cclon;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto wrongnumargs;
- env = SCM_EXTEND_ENV (formals,
- scm_cons2 (arg1,
- arg2,
- scm_eval_args (x, env, proc)),
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
-#endif /* DEVAL */
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
-#endif
- x = SCM_ENTITY_PROCEDURE (proc);
- goto type_dispatch;
- }
- else if (SCM_I_OPERATORP (proc))
- goto operatorn;
- else
- goto badfun;
- case scm_tc7_subr_2:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_subr_0:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_1:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- }
- }
- }
-#ifdef DEVAL
-exit:
- if (scm_check_exit_p && SCM_TRAPS_P)
- if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
- {
- SCM_CLEAR_TRACED_FRAME (debug);
- arg1 = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
- SCM_TRAPS_P = 1;
- if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
- proc = SCM_CDR (arg1);
- }
- scm_i_set_last_debug_frame (debug.prev);
- return proc;
-#endif
-}
-
-
-/* SECTION: This code is compiled once.
- */
-
-#ifndef DEVAL
@@ -4749,343 +3157,11 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
}
#undef FUNC_NAME
-#endif /* !DEVAL */
-
-
-/* SECTION: When DEVAL is defined this code yields scm_dapply.
- * It is compiled twice.
- */
-
-#if 0
-SCM
-scm_apply (SCM proc, SCM arg1, SCM args)
-{}
-#endif
-
-#if 0
-SCM
-scm_dapply (SCM proc, SCM arg1, SCM args)
-{}
-#endif
-
-
-/* Apply a function to a list of arguments.
-
- This function is exported to the Scheme level as taking two
- required arguments and a tail argument, as if it were:
- (lambda (proc arg1 . args) ...)
- Thus, if you just have a list of arguments to pass to a procedure,
- pass the list as ARG1, and '() for ARGS. If you have some fixed
- args, pass the first as ARG1, then cons any remaining fixed args
- onto the front of your argument list, and pass that as ARGS. */
-
-SCM
-SCM_APPLY (SCM proc, SCM arg1, SCM args)
-{
-#ifdef DEVAL
- scm_t_debug_frame debug;
- scm_t_debug_info debug_vect_body;
- debug.prev = scm_i_last_debug_frame ();
- debug.status = SCM_APPLYFRAME;
- debug.vect = &debug_vect_body;
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = SCM_EOL;
- scm_i_set_last_debug_frame (&debug);
-#else
- if (scm_debug_mode_p)
- return scm_dapply (proc, arg1, args);
-#endif
-
- SCM_ASRTGO (SCM_NIMP (proc), badproc);
-
- /* If ARGS is the empty list, then we're calling apply with only two
- arguments --- ARG1 is the list of arguments for PROC. Whatever
- the case, futz with things so that ARG1 is the first argument to
- give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
- rest.
-
- Setting the debug apply frame args this way is pretty messy.
- Perhaps we should store arg1 and args directly in the frame as
- received, and let scm_frame_arguments unpack them, because that's
- a relatively rare operation. This works for now; if the Guile
- developer archives are still around, see Mikael's post of
- 11-Apr-97. */
- if (scm_is_null (args))
- {
- if (scm_is_null (arg1))
- {
- arg1 = SCM_UNDEFINED;
-#ifdef DEVAL
- debug.vect[0].a.args = SCM_EOL;
-#endif
- }
- else
- {
-#ifdef DEVAL
- debug.vect[0].a.args = arg1;
-#endif
- args = SCM_CDR (arg1);
- arg1 = SCM_CAR (arg1);
- }
- }
- else
- {
- args = scm_nconc2last (args);
-#ifdef DEVAL
- debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
- }
-#ifdef DEVAL
- if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
- {
- SCM tmp = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
- SCM_TRAPS_P = 1;
- }
- ENTER_APPLY;
-#endif
-tail:
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_2o:
- if (SCM_UNBNDP (arg1))
- scm_wrong_num_args (proc);
- if (scm_is_null (args))
- args = SCM_UNDEFINED;
- else
- {
- if (! scm_is_null (SCM_CDR (args)))
- scm_wrong_num_args (proc);
- args = SCM_CAR (args);
- }
- RETURN (SCM_SUBRF (proc) (arg1, args));
- case scm_tc7_subr_2:
- if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
- scm_wrong_num_args (proc);
- args = SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args));
- case scm_tc7_subr_0:
- if (!SCM_UNBNDP (arg1))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) ());
- case scm_tc7_subr_1:
- if (SCM_UNBNDP (arg1))
- scm_wrong_num_args (proc);
- case scm_tc7_subr_1o:
- if (!scm_is_null (args))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_dsubr:
- if (SCM_UNBNDP (arg1) || !scm_is_null (args))
- scm_wrong_num_args (proc);
- if (SCM_I_INUMP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
- case scm_tc7_cxr:
- if (SCM_UNBNDP (arg1) || !scm_is_null (args))
- scm_wrong_num_args (proc);
- RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
- case scm_tc7_subr_3:
- if (scm_is_null (args)
- || scm_is_null (SCM_CDR (args))
- || !scm_is_null (SCM_CDDR (args)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
- case scm_tc7_lsubr:
-#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
-#else
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
-#endif
- case scm_tc7_lsubr_2:
- if (!scm_is_pair (args))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
- case scm_tc7_asubr:
- if (scm_is_null (args))
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- while (SCM_NIMP (args))
- {
- SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
- arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
- args = SCM_CDR (args);
- }
- RETURN (arg1);
- case scm_tc7_rpsubr:
- if (scm_is_null (args))
- RETURN (SCM_BOOL_T);
- while (SCM_NIMP (args))
- {
- SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
- if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
- RETURN (SCM_BOOL_F);
- arg1 = SCM_CAR (args);
- args = SCM_CDR (args);
- }
- RETURN (SCM_BOOL_T);
- case scm_tcs_closures:
-#ifdef DEVAL
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
- if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
- scm_wrong_num_args (proc);
-
- /* Copy argument list */
- if (SCM_IMP (arg1))
- args = arg1;
- else
- {
- SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
- for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
- {
- SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
- tl = SCM_CDR (tl);
- }
- SCM_SETCDR (tl, arg1);
- }
-
- args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- args,
- SCM_ENV (proc));
- proc = SCM_CLOSURE_BODY (proc);
- again:
- arg1 = SCM_CDR (proc);
- while (!scm_is_null (arg1))
- {
- if (SCM_IMP (SCM_CAR (proc)))
- {
- if (SCM_ISYMP (SCM_CAR (proc)))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (proc)))
- m_expand_body (proc, args);
- scm_dynwind_end ();
- goto again;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
- }
- else
- (void) EVAL (SCM_CAR (proc), args);
- proc = arg1;
- arg1 = SCM_CDR (proc);
- }
- RETURN (EVALCAR (proc, args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badproc;
- if (SCM_UNBNDP (arg1))
- RETURN (SCM_SMOB_APPLY_0 (proc));
- else if (scm_is_null (args))
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
- else if (scm_is_null (SCM_CDR (args)))
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
- else
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
- case scm_tc7_cclo:
-#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
- arg1 = proc;
- proc = SCM_CCLO_SUBR (proc);
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
- arg1 = proc;
- proc = SCM_CCLO_SUBR (proc);
-#endif
- goto tail;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
- debug.vect[0].a.proc = proc;
-#endif
- goto tail;
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
-#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
- RETURN (scm_apply_generic (proc, args));
- }
- else if (SCM_I_OPERATORP (proc))
- {
- /* operator */
-#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
- arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
-#ifdef DEVAL
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
- if (SCM_NIMP (proc))
- goto tail;
- else
- goto badproc;
- }
- else
- goto badproc;
- default:
- badproc:
- scm_wrong_type_arg ("apply", SCM_ARG1, proc);
- }
-#ifdef DEVAL
-exit:
- if (scm_check_exit_p && SCM_TRAPS_P)
- if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
- {
- SCM_CLEAR_TRACED_FRAME (debug);
- arg1 = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
- SCM_TRAPS_P = 1;
- if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
- proc = SCM_CDR (arg1);
- }
- scm_i_set_last_debug_frame (debug.prev);
- return proc;
-#endif
-}
/* SECTION: The rest of this file is only read once.
*/
-#ifndef DEVAL
-
/* Trampolines
*
* Trampolines make it possible to move procedure application dispatch
@@ -5213,19 +3289,19 @@ call_dsubr_1 (SCM proc, SCM arg1)
{
if (SCM_I_INUMP (arg1))
{
- RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
+ return (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
}
else if (SCM_REALP (arg1))
{
- RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ return (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
}
else if (SCM_BIGP (arg1))
{
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ return (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
}
else if (SCM_FRACTIONP (arg1))
{
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
+ return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
@@ -5870,7 +3946,7 @@ scm_i_eval_x (SCM exp, SCM env)
if (scm_is_symbol (exp))
return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
else
- return SCM_I_XEVAL (exp, env);
+ return SCM_I_XEVAL (exp, env, scm_debug_mode_p);
}
SCM
@@ -5880,7 +3956,7 @@ scm_i_eval (SCM exp, SCM env)
if (scm_is_symbol (exp))
return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
else
- return SCM_I_XEVAL (exp, env);
+ return SCM_I_XEVAL (exp, env, scm_debug_mode_p);
}
SCM
@@ -5964,46 +4040,9 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
*/
#define DEVAL
-#include "eval.c"
-
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* Deprecated in guile 1.7.0 on 2004-03-29. */
-SCM scm_ceval (SCM x, SCM env)
-{
- if (scm_is_pair (x))
- return ceval (x, env);
- else if (scm_is_symbol (x))
- return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
- else
- return SCM_I_XEVAL (x, env);
-}
-
-/* Deprecated in guile 1.7.0 on 2004-03-29. */
-SCM scm_deval (SCM x, SCM env)
-{
- if (scm_is_pair (x))
- return deval (x, env);
- else if (scm_is_symbol (x))
- return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
- else
- return SCM_I_XEVAL (x, env);
-}
-
-static SCM
-dispatching_eval (SCM x, SCM env)
-{
- if (scm_debug_mode_p)
- return scm_deval (x, env);
- else
- return scm_ceval (x, env);
-}
-
-/* Deprecated in guile 1.7.0 on 2004-03-29. */
-SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval;
-
-#endif
+#include "eval.i.c"
+#undef DEVAL
+#include "eval.i.c"
void
@@ -6013,11 +4052,9 @@ scm_init_eval ()
scm_i_pthread_mutexattr_recursive);
scm_init_opts (scm_evaluator_traps,
- scm_evaluator_trap_table,
- SCM_N_EVALUATOR_TRAPS);
+ scm_evaluator_trap_table);
scm_init_opts (scm_eval_options_interface,
- scm_eval_opts,
- SCM_N_EVAL_OPTIONS);
+ scm_eval_opts);
scm_tc16_promise = scm_make_smob_type ("promise", 0);
scm_set_smob_print (scm_tc16_promise, promise_print);
@@ -6036,10 +4073,9 @@ scm_init_eval ()
scm_add_feature ("delay");
}
-#endif /* !DEVAL */
-
/*
Local Variables:
c-file-style: "gnu"
End:
*/
+
diff --git a/libguile/eval.h b/libguile/eval.h
index 7d856a00b..247cf164e 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -32,25 +32,6 @@
/* {Options}
*/
-SCM_API scm_t_option scm_eval_opts[];
-
-#define SCM_EVAL_STACK scm_eval_opts[0].val
-#define SCM_N_EVAL_OPTIONS 1
-
-SCM_API long scm_eval_stack;
-
-SCM_API scm_t_option scm_evaluator_trap_table[];
-
-SCM_API SCM scm_eval_options_interface (SCM setting);
-
-#define SCM_TRAPS_P scm_evaluator_trap_table[0].val
-#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val
-#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val
-#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val
-#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val))
-#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val))
-#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val))
-#define SCM_N_EVALUATOR_TRAPS 7
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
new file mode 100644
index 000000000..c1e1fb62e
--- /dev/null
+++ b/libguile/eval.i.c
@@ -0,0 +1,1942 @@
+/*
+ * eval.i.c - actual evaluator code for GUILE
+ *
+ * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#undef RETURN
+#undef ENTER_APPLY
+#undef PREP_APPLY
+#undef CEVAL
+#undef SCM_APPLY
+#undef EVAL_DEBUGGING_P
+
+
+#ifdef DEVAL
+
+/*
+ This code is specific for the debugging support.
+ */
+
+#define EVAL_DEBUGGING_P 1
+#define CEVAL deval /* Substitute all uses of ceval */
+#define SCM_APPLY scm_dapply
+#define PREP_APPLY(p, l) \
+{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
+
+#define ENTER_APPLY \
+do { \
+ SCM_SET_ARGSREADY (debug);\
+ if (scm_check_apply_p && SCM_TRAPS_P)\
+ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
+ {\
+ SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
+ SCM_SET_TRACED_FRAME (debug); \
+ SCM_TRAPS_P = 0;\
+ tmp = scm_make_debugobj (&debug);\
+ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
+ SCM_TRAPS_P = 1;\
+ }\
+} while (0)
+
+#define RETURN(e) do { proc = (e); goto exit; } while (0)
+
+#ifdef STACK_CHECKING
+# ifndef EVAL_STACK_CHECKING
+# define EVAL_STACK_CHECKING
+# endif /* EVAL_STACK_CHECKING */
+#endif /* STACK_CHECKING */
+
+
+
+
+static SCM
+deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
+{
+ SCM *results = lloc;
+ while (scm_is_pair (l))
+ {
+ const SCM res = SCM_I_XEVALCAR (l, env, 1);
+
+ *lloc = scm_list_1 (res);
+ lloc = SCM_CDRLOC (*lloc);
+ l = SCM_CDR (l);
+ }
+ if (!scm_is_null (l))
+ scm_wrong_num_args (proc);
+ return *results;
+}
+
+
+#else /* DEVAL */
+
+/*
+ Code is specific to debugging-less support.
+ */
+
+
+#define CEVAL ceval
+#define SCM_APPLY scm_apply
+#define PREP_APPLY(proc, args)
+#define ENTER_APPLY
+#define RETURN(x) do { return x; } while (0)
+#define EVAL_DEBUGGING_P 0
+
+#ifdef STACK_CHECKING
+# ifndef NO_CEVAL_STACK_CHECKING
+# define EVAL_STACK_CHECKING
+# endif
+#endif
+
+
+
+
+static void
+ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
+{
+ SCM argv[10];
+ int i = 0, imax = sizeof (argv) / sizeof (SCM);
+
+ while (!scm_is_null (init_forms))
+ {
+ if (imax == i)
+ {
+ ceval_letrec_inits (env, init_forms, init_values_eol);
+ break;
+ }
+ argv[i++] = SCM_I_XEVALCAR (init_forms, env, 0);
+ init_forms = SCM_CDR (init_forms);
+ }
+
+ for (i--; i >= 0; i--)
+ {
+ **init_values_eol = scm_list_1 (argv[i]);
+ *init_values_eol = SCM_CDRLOC (**init_values_eol);
+ }
+}
+
+static SCM
+scm_ceval_args (SCM l, SCM env, SCM proc)
+{
+ SCM results = SCM_EOL, *lloc = &results, res;
+ while (scm_is_pair (l))
+ {
+ res = EVALCAR (l, env);
+
+ *lloc = scm_list_1 (res);
+ lloc = SCM_CDRLOC (*lloc);
+ l = SCM_CDR (l);
+ }
+ if (!scm_is_null (l))
+ scm_wrong_num_args (proc);
+ return results;
+}
+
+
+SCM
+scm_eval_args (SCM l, SCM env, SCM proc)
+{
+ return scm_ceval_args (l, env, proc);
+}
+
+
+
+#endif
+
+
+
+
+#define EVAL(x, env) SCM_I_XEVAL(x, env, EVAL_DEBUGGING_P)
+#define EVALCAR(x, env) SCM_I_XEVALCAR(x, env, EVAL_DEBUGGING_P)
+
+
+
+/* Update the toplevel environment frame ENV so that it refers to the
+ * current module. */
+#define UPDATE_TOPLEVEL_ENV(env) \
+ do { \
+ SCM p = scm_current_module_lookup_closure (); \
+ if (p != SCM_CAR (env)) \
+ env = scm_top_level_env (p); \
+ } while (0)
+
+
+#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
+ ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
+
+
+/* This is the evaluator. Like any real monster, it has three heads:
+ *
+ * ceval is the non-debugging evaluator, deval is the debugging version. Both
+ * are implemented using a common code base, using the following mechanism:
+ * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
+ * is no function CEVAL, but the code for CEVAL actually compiles to either
+ * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
+ * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
+ * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
+ * are enclosed within #ifdef DEVAL ... #endif.
+ *
+ * All three (ceval, deval and their common implementation CEVAL) take two
+ * input parameters, x and env: x is a single expression to be evalutated.
+ * env is the environment in which bindings are searched.
+ *
+ * x is known to be a pair. Since x is a single expression, it is necessarily
+ * in a tail position. If x is just a call to another function like in the
+ * expression (foo exp1 exp2 ...), the realization of that call therefore
+ * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
+ * however, may do so). This is realized by making extensive use of 'goto'
+ * statements within the evaluator: The gotos replace recursive calls to
+ * CEVAL, thus re-using the same stack frame that CEVAL was already using.
+ * If, however, x represents some form that requires to evaluate a sequence of
+ * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
+ * performed for all but the last expression of that sequence. */
+
+static SCM
+CEVAL (SCM x, SCM env)
+{
+ SCM proc, arg1;
+#ifdef DEVAL
+ scm_t_debug_frame debug;
+ scm_t_debug_info *debug_info_end;
+ debug.prev = scm_i_last_debug_frame ();
+ debug.status = 0;
+ /*
+ * The debug.vect contains twice as much scm_t_debug_info frames as the
+ * user has specified with (debug-set! frames <n>).
+ *
+ * Even frames are eval frames, odd frames are apply frames.
+ */
+ debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
+ * sizeof (scm_t_debug_info));
+ debug.info = debug.vect;
+ debug_info_end = debug.vect + scm_debug_eframe_size;
+ scm_i_set_last_debug_frame (&debug);
+#endif
+#ifdef EVAL_STACK_CHECKING
+ if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
+ {
+#ifdef DEVAL
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+#endif
+ scm_report_stack_overflow ();
+ }
+#endif
+
+#ifdef DEVAL
+ goto start;
+#endif
+
+loop:
+#ifdef DEVAL
+ SCM_CLEAR_ARGSREADY (debug);
+ if (SCM_OVERFLOWP (debug))
+ --debug.info;
+ /*
+ * In theory, this should be the only place where it is necessary to
+ * check for space in debug.vect since both eval frames and
+ * available space are even.
+ *
+ * For this to be the case, however, it is necessary that primitive
+ * special forms which jump back to `loop', `begin' or some similar
+ * label call PREP_APPLY.
+ */
+ else if (++debug.info >= debug_info_end)
+ {
+ SCM_SET_OVERFLOW (debug);
+ debug.info -= 2;
+ }
+
+start:
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+ if (scm_check_entry_p && SCM_TRAPS_P)
+ {
+ if (SCM_ENTER_FRAME_P
+ || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
+ {
+ SCM stackrep;
+ SCM tail = scm_from_bool (SCM_TAILRECP (debug));
+ SCM_SET_TAILREC (debug);
+ stackrep = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
+ scm_sym_enter_frame,
+ stackrep,
+ tail,
+ unmemoize_expression (x, env));
+ SCM_TRAPS_P = 1;
+ if (scm_is_pair (stackrep) &&
+ scm_is_eq (SCM_CAR (stackrep), sym_instead))
+ {
+ /* This gives the possibility for the debugger to modify
+ the source expression before evaluation. */
+ x = SCM_CDR (stackrep);
+ if (SCM_IMP (x))
+ RETURN (x);
+ }
+ }
+ }
+#endif
+dispatch:
+ SCM_TICK;
+ if (SCM_ISYMP (SCM_CAR (x)))
+ {
+ switch (ISYMNUM (SCM_CAR (x)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ x = SCM_CDR (x);
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ SCM test_result = EVALCAR (x, env);
+ if (scm_is_false (test_result) || SCM_NILP (test_result))
+ RETURN (SCM_BOOL_F);
+ else
+ x = SCM_CDR (x);
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ x = SCM_CDR (x);
+ if (scm_is_null (x))
+ RETURN (SCM_UNSPECIFIED);
+
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+
+ begin:
+ /* If we are on toplevel with a lookup closure, we need to sync
+ with the current module. */
+ if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
+ {
+ UPDATE_TOPLEVEL_ENV (env);
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ EVALCAR (x, env);
+ UPDATE_TOPLEVEL_ENV (env);
+ x = SCM_CDR (x);
+ }
+ goto carloop;
+ }
+ else
+ goto nontoplevel_begin;
+
+ nontoplevel_begin:
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ const SCM form = SCM_CAR (x);
+ if (SCM_IMP (form))
+ {
+ if (SCM_ISYMP (form))
+ {
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (x)))
+ m_expand_body (x, env);
+ scm_dynwind_end ();
+ goto nontoplevel_begin;
+ }
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
+ }
+ else
+ (void) EVAL (form, env);
+ x = SCM_CDR (x);
+ }
+
+ carloop:
+ {
+ /* scm_eval last form in list */
+ const SCM last_form = SCM_CAR (x);
+
+ if (scm_is_pair (last_form))
+ {
+ /* This is by far the most frequent case. */
+ x = last_form;
+ goto loop; /* tail recurse */
+ }
+ else if (SCM_IMP (last_form))
+ RETURN (SCM_I_EVALIM (last_form, env));
+ else if (SCM_VARIABLEP (last_form))
+ RETURN (SCM_VARIABLE_REF (last_form));
+ else if (scm_is_symbol (last_form))
+ RETURN (*scm_lookupcar (x, env, 1));
+ else
+ RETURN (last_form);
+ }
+
+
+ case (ISYMNUM (SCM_IM_CASE)):
+ x = SCM_CDR (x);
+ {
+ const SCM key = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ while (!scm_is_null (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ SCM labels = SCM_CAR (clause);
+ if (scm_is_eq (labels, SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ while (!scm_is_null (labels))
+ {
+ const SCM label = SCM_CAR (labels);
+ if (scm_is_eq (label, key)
+ || scm_is_true (scm_eqv_p (label, key)))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ labels = SCM_CDR (labels);
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_COND)):
+ x = SCM_CDR (x);
+ while (!scm_is_null (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ arg1 = EVALCAR (clause, env);
+ /* SRFI 61 extended cond */
+ if (!scm_is_null (SCM_CDR (clause))
+ && !scm_is_null (SCM_CDDR (clause))
+ && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
+ {
+ SCM xx, guard_result;
+ if (SCM_VALUESP (arg1))
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ else
+ arg1 = scm_list_1 (arg1);
+ xx = SCM_CDR (clause);
+ proc = EVALCAR (xx, env);
+ guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
+ if (scm_is_true (guard_result)
+ && !SCM_NILP (guard_result))
+ {
+ proc = SCM_CDDR (xx);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+ }
+ }
+ else if (scm_is_true (arg1) && !SCM_NILP (arg1))
+ {
+ x = SCM_CDR (clause);
+ if (scm_is_null (x))
+ RETURN (arg1);
+ else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ proc = SCM_CDR (x);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ goto evap1;
+ }
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_DO)):
+ x = SCM_CDR (x);
+ {
+ /* Compute the initialization values and the initial environment. */
+ SCM init_forms = SCM_CAR (x);
+ SCM init_values = SCM_EOL;
+ while (!scm_is_null (init_forms))
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDR (x);
+ {
+ SCM test_form = SCM_CAR (x);
+ SCM body_forms = SCM_CADR (x);
+ SCM step_forms = SCM_CDDR (x);
+
+ SCM test_result = EVALCAR (test_form, env);
+
+ while (scm_is_false (test_result) || SCM_NILP (test_result))
+ {
+ {
+ /* Evaluate body forms. */
+ SCM temp_forms;
+ for (temp_forms = body_forms;
+ !scm_is_null (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ SCM form = SCM_CAR (temp_forms);
+ /* Dirk:FIXME: We only need to eval forms that may have
+ * a side effect here. This is only true for forms that
+ * start with a pair. All others are just constants.
+ * Since with the current memoizer 'form' may hold a
+ * constant, we call EVAL here to handle the constant
+ * cases. In the long run it would make sense to have
+ * the macro transformer of 'do' eliminate all forms
+ * that have no sideeffect. Then instead of EVAL we
+ * could call CEVAL directly here. */
+ (void) EVAL (form, env);
+ }
+ }
+
+ {
+ /* Evaluate the step expressions. */
+ SCM temp_forms;
+ SCM step_values = SCM_EOL;
+ for (temp_forms = step_forms;
+ !scm_is_null (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ const SCM value = EVALCAR (temp_forms, env);
+ step_values = scm_cons (value, step_values);
+ }
+ env = SCM_EXTEND_ENV (SCM_CAAR (env),
+ step_values,
+ SCM_CDR (env));
+ }
+
+ test_result = EVALCAR (test_form, env);
+ }
+ }
+ x = SCM_CDAR (x);
+ if (scm_is_null (x))
+ RETURN (SCM_UNSPECIFIED);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_IF)):
+ x = SCM_CDR (x);
+ {
+ SCM test_result = EVALCAR (x, env);
+ x = SCM_CDR (x); /* then expression */
+ if (scm_is_false (test_result) || SCM_NILP (test_result))
+ {
+ x = SCM_CDR (x); /* else expression */
+ if (scm_is_null (x))
+ RETURN (SCM_UNSPECIFIED);
+ }
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+
+ case (ISYMNUM (SCM_IM_LET)):
+ x = SCM_CDR (x);
+ {
+ SCM init_forms = SCM_CADR (x);
+ SCM init_values = SCM_EOL;
+ do
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ while (!scm_is_null (init_forms));
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_LETREC)):
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
+ x = SCM_CDR (x);
+ {
+ SCM init_forms = SCM_CAR (x);
+ SCM init_values = scm_list_1 (SCM_BOOL_T);
+ SCM *init_values_eol = SCM_CDRLOC (init_values);
+ ceval_letrec_inits (env, init_forms, &init_values_eol);
+ SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_LETSTAR)):
+ x = SCM_CDR (x);
+ {
+ SCM bindings = SCM_CAR (x);
+ if (!scm_is_null (bindings))
+ {
+ do
+ {
+ SCM name = SCM_CAR (bindings);
+ SCM init = SCM_CDR (bindings);
+ env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
+ bindings = SCM_CDR (init);
+ }
+ while (!scm_is_null (bindings));
+ }
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_OR)):
+ x = SCM_CDR (x);
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ SCM val = EVALCAR (x, env);
+ if (scm_is_true (val) && !SCM_NILP (val))
+ RETURN (val);
+ else
+ x = SCM_CDR (x);
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+
+ case (ISYMNUM (SCM_IM_LAMBDA)):
+ RETURN (scm_closure (SCM_CDR (x), env));
+
+
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ RETURN (SCM_CDR (x));
+
+
+ case (ISYMNUM (SCM_IM_SET_X)):
+ x = SCM_CDR (x);
+ {
+ SCM *location;
+ SCM variable = SCM_CAR (x);
+ if (SCM_ILOCP (variable))
+ location = scm_ilookup (variable, env);
+ else if (SCM_VARIABLEP (variable))
+ location = SCM_VARIABLE_LOC (variable);
+ else
+ {
+ /* (scm_is_symbol (variable)) is known to be true */
+ variable = lazy_memoize_variable (variable, env);
+ SCM_SETCAR (x, variable);
+ location = SCM_VARIABLE_LOC (variable);
+ }
+ x = SCM_CDR (x);
+ *location = EVALCAR (x, env);
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_APPLY)):
+ /* Evaluate the procedure to be applied. */
+ x = SCM_CDR (x);
+ proc = EVALCAR (x, env);
+ PREP_APPLY (proc, SCM_EOL);
+
+ /* Evaluate the argument holding the list of arguments */
+ x = SCM_CDR (x);
+ arg1 = EVALCAR (x, env);
+
+ apply_proc:
+ /* Go here to tail-apply a procedure. PROC is the procedure and
+ * ARG1 is the list of arguments. PREP_APPLY must have been called
+ * before jumping to apply_proc. */
+ if (SCM_CLOSUREP (proc))
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+#ifdef DEVAL
+ debug.info->a.args = arg1;
+#endif
+ if (scm_badargsp (formals, arg1))
+ scm_wrong_num_args (proc);
+ ENTER_APPLY;
+ /* Copy argument list */
+ if (SCM_NULL_OR_NIL_P (arg1))
+ env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ else
+ {
+ SCM args = scm_list_1 (SCM_CAR (arg1));
+ SCM tail = args;
+ arg1 = SCM_CDR (arg1);
+ while (!SCM_NULL_OR_NIL_P (arg1))
+ {
+ SCM new_tail = scm_list_1 (SCM_CAR (arg1));
+ SCM_SETCDR (tail, new_tail);
+ tail = new_tail;
+ arg1 = SCM_CDR (arg1);
+ }
+ env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
+ }
+
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+ else
+ {
+ ENTER_APPLY;
+ RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
+ }
+
+
+ case (ISYMNUM (SCM_IM_CONT)):
+ {
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (!first)
+ RETURN (val);
+ else
+ {
+ arg1 = val;
+ proc = SCM_CDR (x);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ goto evap1;
+ }
+ }
+
+
+ case (ISYMNUM (SCM_IM_DELAY)):
+ RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
+
+#if 0
+ /* See futures.h for a comment why futures are not enabled.
+ */
+ case (ISYMNUM (SCM_IM_FUTURE)):
+ RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
+#endif
+
+ /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
+ code (type_dispatch) is intended to be the tail of the case
+ clause for the internal macro SCM_IM_DISPATCH. Please don't
+ remove it from this location without discussing it with Mikael
+ <djurfeldt@nada.kth.se> */
+
+ /* The type dispatch code is duplicated below
+ * (c.f. objects.c:scm_mcache_compute_cmethod) since that
+ * cuts down execution time for type dispatch to 50%. */
+ type_dispatch: /* inputs: x, arg1 */
+ /* Type dispatch means to determine from the types of the function
+ * arguments (i. e. the 'signature' of the call), which method from
+ * a generic function is to be called. This process of selecting
+ * the right method takes some time. To speed it up, guile uses
+ * caching: Together with the macro call to dispatch the signatures
+ * of some previous calls to that generic function from the same
+ * place are stored (in the code!) in a cache that we call the
+ * 'method cache'. This is done since it is likely, that
+ * consecutive calls to dispatch from that position in the code will
+ * have the same signature. Thus, the type dispatch works as
+ * follows: First, determine a hash value from the signature of the
+ * actual arguments. Second, use this hash value as an index to
+ * find that same signature in the method cache stored at this
+ * position in the code. If found, you have also found the
+ * corresponding method that belongs to that signature. If the
+ * signature is not found in the method cache, you have to perform a
+ * full search over all signatures stored with the generic
+ * function. */
+ {
+ unsigned long int specializers;
+ unsigned long int hash_value;
+ unsigned long int cache_end_pos;
+ unsigned long int mask;
+ SCM method_cache;
+
+ {
+ SCM z = SCM_CDDR (x);
+ SCM tmp = SCM_CADR (z);
+ specializers = scm_to_ulong (SCM_CAR (z));
+
+ /* Compute a hash value for searching the method cache. There
+ * are two variants for computing the hash value, a (rather)
+ * complicated one, and a simple one. For the complicated one
+ * explained below, tmp holds a number that is used in the
+ * computation. */
+ if (scm_is_simple_vector (tmp))
+ {
+ /* This method of determining the hash value is much
+ * simpler: Set the hash value to zero and just perform a
+ * linear search through the method cache. */
+ method_cache = tmp;
+ mask = (unsigned long int) ((long) -1);
+ hash_value = 0;
+ cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache);
+ }
+ else
+ {
+ /* Use the signature of the actual arguments to determine
+ * the hash value. This is done as follows: Each class has
+ * an array of random numbers, that are determined when the
+ * class is created. The integer 'hashset' is an index into
+ * that array of random numbers. Now, from all classes that
+ * are part of the signature of the actual arguments, the
+ * random numbers at index 'hashset' are taken and summed
+ * up, giving the hash value. The value of 'hashset' is
+ * stored at the call to dispatch. This allows to have
+ * different 'formulas' for calculating the hash value at
+ * different places where dispatch is called. This allows
+ * to optimize the hash formula at every individual place
+ * where dispatch is called, such that hopefully the hash
+ * value that is computed will directly point to the right
+ * method in the method cache. */
+ unsigned long int hashset = scm_to_ulong (tmp);
+ unsigned long int counter = specializers + 1;
+ SCM tmp_arg = arg1;
+ hash_value = 0;
+ while (!scm_is_null (tmp_arg) && counter != 0)
+ {
+ SCM class = scm_class_of (SCM_CAR (tmp_arg));
+ hash_value += SCM_INSTANCE_HASH (class, hashset);
+ tmp_arg = SCM_CDR (tmp_arg);
+ counter--;
+ }
+ z = SCM_CDDR (z);
+ method_cache = SCM_CADR (z);
+ mask = scm_to_ulong (SCM_CAR (z));
+ hash_value &= mask;
+ cache_end_pos = hash_value;
+ }
+ }
+
+ {
+ /* Search the method cache for a method with a matching
+ * signature. Start the search at position 'hash_value'. The
+ * hashing implementation uses linear probing for conflict
+ * resolution, that is, if the signature in question is not
+ * found at the starting index in the hash table, the next table
+ * entry is tried, and so on, until in the worst case the whole
+ * cache has been searched, but still the signature has not been
+ * found. */
+ SCM z;
+ do
+ {
+ SCM args = arg1; /* list of arguments */
+ z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value);
+ while (!scm_is_null (args))
+ {
+ /* More arguments than specifiers => CLASS != ENV */
+ SCM class_of_arg = scm_class_of (SCM_CAR (args));
+ if (!scm_is_eq (class_of_arg, SCM_CAR (z)))
+ goto next_method;
+ args = SCM_CDR (args);
+ z = SCM_CDR (z);
+ }
+ /* Fewer arguments than specifiers => CAR != ENV */
+ if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
+ goto apply_cmethod;
+ next_method:
+ hash_value = (hash_value + 1) & mask;
+ } while (hash_value != cache_end_pos);
+
+ /* No appropriate method was found in the cache. */
+ z = scm_memoize_method (x, arg1);
+
+ apply_cmethod: /* inputs: z, arg1 */
+ {
+ SCM formals = SCM_CMETHOD_FORMALS (z);
+ env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+ x = SCM_CMETHOD_BODY (z);
+ goto nontoplevel_begin;
+ }
+ }
+ }
+
+
+ case (ISYMNUM (SCM_IM_SLOT_REF)):
+ x = SCM_CDR (x);
+ {
+ SCM instance = EVALCAR (x, env);
+ unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
+ RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
+ }
+
+
+ case (ISYMNUM (SCM_IM_SLOT_SET_X)):
+ x = SCM_CDR (x);
+ {
+ SCM instance = EVALCAR (x, env);
+ unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
+ SCM value = EVALCAR (SCM_CDDR (x), env);
+ SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
+ RETURN (SCM_UNSPECIFIED);
+ }
+
+
+#if SCM_ENABLE_ELISP
+
+ case (ISYMNUM (SCM_IM_NIL_COND)):
+ {
+ SCM test_form = SCM_CDR (x);
+ x = SCM_CDR (test_form);
+ while (!SCM_NULL_OR_NIL_P (x))
+ {
+ SCM test_result = EVALCAR (test_form, env);
+ if (!(scm_is_false (test_result)
+ || SCM_NULL_OR_NIL_P (test_result)))
+ {
+ if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
+ RETURN (test_result);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+ }
+ else
+ {
+ test_form = SCM_CDR (x);
+ x = SCM_CDR (test_form);
+ }
+ }
+ x = test_form;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+ }
+
+#endif /* SCM_ENABLE_ELISP */
+
+ case (ISYMNUM (SCM_IM_BIND)):
+ {
+ SCM vars, exps, vals;
+
+ x = SCM_CDR (x);
+ vars = SCM_CAAR (x);
+ exps = SCM_CDAR (x);
+ vals = SCM_EOL;
+ while (!scm_is_null (exps))
+ {
+ vals = scm_cons (EVALCAR (exps, env), vals);
+ exps = SCM_CDR (exps);
+ }
+
+ scm_swap_bindings (vars, vals);
+ scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
+
+ /* Ignore all but the last evaluation result. */
+ for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
+ {
+ if (scm_is_pair (SCM_CAR (x)))
+ CEVAL (SCM_CAR (x), env);
+ }
+ proc = EVALCAR (x, env);
+
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ scm_swap_bindings (vars, vals);
+
+ RETURN (proc);
+ }
+
+
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ {
+ SCM producer;
+
+ x = SCM_CDR (x);
+ producer = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ proc = EVALCAR (x, env); /* proc is the consumer. */
+ arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
+ if (SCM_VALUESP (arg1))
+ {
+ /* The list of arguments is not copied. Rather, it is assumed
+ * that this has been done by the 'values' procedure. */
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ }
+ else
+ {
+ arg1 = scm_list_1 (arg1);
+ }
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+ }
+
+
+ default:
+ break;
+ }
+ }
+ else
+ {
+ if (SCM_VARIABLEP (SCM_CAR (x)))
+ proc = SCM_VARIABLE_REF (SCM_CAR (x));
+ else if (SCM_ILOCP (SCM_CAR (x)))
+ proc = *scm_ilookup (SCM_CAR (x), env);
+ else if (scm_is_pair (SCM_CAR (x)))
+ proc = CEVAL (SCM_CAR (x), env);
+ else if (scm_is_symbol (SCM_CAR (x)))
+ {
+ SCM orig_sym = SCM_CAR (x);
+ {
+ SCM *location = scm_lookupcar1 (x, env, 1);
+ if (location == NULL)
+ {
+ /* we have lost the race, start again. */
+ goto dispatch;
+ }
+ proc = *location;
+#ifdef DEVAL
+ if (scm_check_memoize_p && SCM_TRAPS_P)
+ {
+ SCM_CLEAR_TRACED_FRAME (debug);
+ SCM arg1 = scm_make_debugobj (&debug);
+ SCM retval = SCM_BOOL_T;
+ SCM_TRAPS_P = 0;
+ retval = scm_call_4 (SCM_MEMOIZE_HDLR,
+ scm_sym_memoize_symbol,
+ arg1, x, env);
+
+ /*
+ do something with retval?
+ */
+ SCM_TRAPS_P = 1;
+ }
+#endif
+ }
+
+ if (SCM_MACROP (proc))
+ {
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
+ lookupcar */
+ handle_a_macro: /* inputs: x, env, proc */
+#ifdef DEVAL
+ /* Set a flag during macro expansion so that macro
+ application frames can be deleted from the backtrace. */
+ SCM_SET_MACROEXP (debug);
+#endif
+ arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
+ scm_cons (env, scm_listofnull));
+#ifdef DEVAL
+ SCM_CLEAR_MACROEXP (debug);
+#endif
+ switch (SCM_MACRO_TYPE (proc))
+ {
+ case 3:
+ case 2:
+ if (!scm_is_pair (arg1))
+ arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
+
+ assert (!scm_is_eq (x, SCM_CAR (arg1))
+ && !scm_is_eq (x, SCM_CDR (arg1)));
+
+#ifdef DEVAL
+ if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
+ {
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (arg1));
+ SCM_SETCDR (x, SCM_CDR (arg1));
+ SCM_CRITICAL_SECTION_END;
+ goto dispatch;
+ }
+ /* Prevent memoizing of debug info expression. */
+ debug.info->e.exp = scm_cons_source (debug.info->e.exp,
+ SCM_CAR (x),
+ SCM_CDR (x));
+#endif
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (arg1));
+ SCM_SETCDR (x, SCM_CDR (arg1));
+ SCM_CRITICAL_SECTION_END;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto loop;
+#if SCM_ENABLE_DEPRECATED == 1
+ case 1:
+ x = arg1;
+ if (SCM_NIMP (x))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto loop;
+ }
+ else
+ RETURN (arg1);
+#endif
+ case 0:
+ RETURN (arg1);
+ }
+ }
+ }
+ else
+ proc = SCM_CAR (x);
+
+ if (SCM_MACROP (proc))
+ goto handle_a_macro;
+ }
+
+
+ /* When reaching this part of the code, the following is granted: Variable x
+ * holds the first pair of an expression of the form (<function> arg ...).
+ * Variable proc holds the object that resulted from the evaluation of
+ * <function>. In the following, the arguments (if any) will be evaluated,
+ * and proc will be applied to them. If proc does not really hold a
+ * function object, this will be signalled as an error on the scheme
+ * level. If the number of arguments does not match the number of arguments
+ * that are allowed to be passed to proc, also an error on the scheme level
+ * will be signalled. */
+
+ PREP_APPLY (proc, SCM_EOL);
+ if (scm_is_null (SCM_CDR (x))) {
+ ENTER_APPLY;
+ evap0:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* no arguments given */
+ case scm_tc7_subr_0:
+ RETURN (SCM_SUBRF (proc) ());
+ case scm_tc7_subr_1o:
+ RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (SCM_EOL));
+ case scm_tc7_rpsubr:
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_0 (proc));
+ case scm_tc7_cclo:
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_list_1 (arg1);
+#endif
+ goto evap1;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap0;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_pair (formals))
+ goto wrongnumargs;
+ x = SCM_CLOSURE_BODY (proc);
+ env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ goto nontoplevel_begin;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
+ arg1 = SCM_EOL;
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_list_1 (arg1);
+#endif
+ goto evap1;
+ }
+ else
+ goto badfun;
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ wrongnumargs:
+ scm_wrong_num_args (proc);
+ default:
+ badfun:
+ scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
+ }
+ }
+
+ /* must handle macros by here */
+ x = SCM_CDR (x);
+ if (scm_is_pair (x))
+ arg1 = EVALCAR (x, env);
+ else
+ scm_wrong_num_args (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_list_1 (arg1);
+#endif
+ x = SCM_CDR (x);
+ {
+ SCM arg2;
+ if (scm_is_null (x))
+ {
+ ENTER_APPLY;
+ evap1: /* inputs: proc, arg1 */
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* have one argument in arg1 */
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_1o:
+ RETURN (SCM_SUBRF (proc) (arg1));
+ case scm_tc7_dsubr:
+ if (SCM_I_INUMP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+ else if (SCM_FRACTIONP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
+ }
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1,
+ scm_i_symbol_chars (SCM_SNAME (proc)));
+ case scm_tc7_cxr:
+ RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
+ case scm_tc7_rpsubr:
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ case scm_tc7_lsubr:
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
+#endif
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
+ case scm_tc7_cclo:
+ arg2 = arg1;
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
+ goto evap2;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap1;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ /* clos1: */
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (formals)
+ || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
+ goto wrongnumargs;
+ x = SCM_CLOSURE_BODY (proc);
+#ifdef DEVAL
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
+#else
+ env = SCM_EXTEND_ENV (formals,
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
+#endif
+ goto nontoplevel_begin;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
+#ifdef DEVAL
+ arg1 = debug.info->a.args;
+#else
+ arg1 = scm_list_1 (arg1);
+#endif
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ arg2 = arg1;
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
+ goto evap2;
+ }
+ else
+ goto badfun;
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ scm_wrong_num_args (proc);
+ default:
+ goto badfun;
+ }
+ }
+ if (scm_is_pair (x))
+ arg2 = EVALCAR (x, env);
+ else
+ scm_wrong_num_args (proc);
+
+ { /* have two or more arguments */
+#ifdef DEVAL
+ debug.info->a.args = scm_list_2 (arg1, arg2);
+#endif
+ x = SCM_CDR (x);
+ if (scm_is_null (x)) {
+ ENTER_APPLY;
+ evap2:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* have two arguments */
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_lsubr:
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
+#endif
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
+ cclon:
+ case scm_tc7_cclo:
+#ifdef DEVAL
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
+#else
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_ceval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
+#endif
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
+#ifdef DEVAL
+ arg1 = debug.info->a.args;
+#else
+ arg1 = scm_list_2 (arg1, arg2);
+#endif
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ operatorn:
+#ifdef DEVAL
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
+#else
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_ceval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
+#endif
+ }
+ else
+ goto badfun;
+ case scm_tc7_subr_0:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_3:
+ scm_wrong_num_args (proc);
+ default:
+ goto badfun;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap2;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ /* clos2: */
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (formals)
+ || (scm_is_pair (formals)
+ && (scm_is_null (SCM_CDR (formals))
+ || (scm_is_pair (SCM_CDR (formals))
+ && scm_is_pair (SCM_CDDR (formals))))))
+ goto wrongnumargs;
+#ifdef DEVAL
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
+#else
+ env = SCM_EXTEND_ENV (formals,
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
+#endif
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+ }
+ }
+ if (!scm_is_pair (x))
+ scm_wrong_num_args (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons2 (arg1, arg2,
+ deval_args (x, env, proc,
+ SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
+#endif
+ ENTER_APPLY;
+ evap3:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* have 3 or more arguments */
+#ifdef DEVAL
+ case scm_tc7_subr_3:
+ if (!scm_is_null (SCM_CDR (x)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CADDR (debug.info->a.args)));
+ case scm_tc7_asubr:
+ arg1 = SCM_SUBRF(proc)(arg1, arg2);
+ arg2 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
+ arg2 = SCM_CDR (arg2);
+ }
+ while (SCM_NIMP (arg2));
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ arg1 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
+ RETURN (SCM_BOOL_F);
+ arg2 = SCM_CAR (arg1);
+ arg1 = SCM_CDR (arg1);
+ }
+ while (SCM_NIMP (arg1));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_cclo:
+ goto cclon;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ debug.info->a.proc = proc;
+ if (!SCM_CLOSUREP (proc))
+ goto evap3;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (formals)
+ || (scm_is_pair (formals)
+ && (scm_is_null (SCM_CDR (formals))
+ || (scm_is_pair (SCM_CDR (formals))
+ && scm_badargsp (SCM_CDDR (formals), x)))))
+ goto wrongnumargs;
+ SCM_SET_ARGSREADY (debug);
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+#else /* DEVAL */
+ case scm_tc7_subr_3:
+ if (!scm_is_null (SCM_CDR (x)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
+ case scm_tc7_asubr:
+ arg1 = SCM_SUBRF (proc) (arg1, arg2);
+ do
+ {
+ arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
+ x = SCM_CDR(x);
+ }
+ while (!scm_is_null (x));
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ do
+ {
+ arg1 = EVALCAR (x, env);
+ if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
+ RETURN (SCM_BOOL_F);
+ arg2 = arg1;
+ x = SCM_CDR (x);
+ }
+ while (!scm_is_null (x));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
+ arg2,
+ scm_ceval_args (x, env, proc))));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
+ scm_ceval_args (x, env, proc)));
+ case scm_tc7_cclo:
+ goto cclon;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ if (!SCM_CLOSUREP (proc))
+ goto evap3;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (formals)
+ || (scm_is_pair (formals)
+ && (scm_is_null (SCM_CDR (formals))
+ || (scm_is_pair (SCM_CDR (formals))
+ && scm_badargsp (SCM_CDDR (formals), x)))))
+ goto wrongnumargs;
+ env = SCM_EXTEND_ENV (formals,
+ scm_cons2 (arg1,
+ arg2,
+ scm_ceval_args (x, env, proc)),
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+#endif /* DEVAL */
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+#ifdef DEVAL
+ arg1 = debug.info->a.args;
+#else
+ arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc));
+#endif
+ x = SCM_ENTITY_PROCEDURE (proc);
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ goto operatorn;
+ else
+ goto badfun;
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_subr_0:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1:
+ scm_wrong_num_args (proc);
+ default:
+ goto badfun;
+ }
+ }
+ }
+#ifdef DEVAL
+exit:
+ if (scm_check_exit_p && SCM_TRAPS_P)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_CLEAR_TRACED_FRAME (debug);
+ arg1 = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
+ SCM_TRAPS_P = 1;
+ if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
+ proc = SCM_CDR (arg1);
+ }
+ scm_i_set_last_debug_frame (debug.prev);
+ return proc;
+#endif
+}
+
+
+
+
+/* Apply a function to a list of arguments.
+
+ This function is exported to the Scheme level as taking two
+ required arguments and a tail argument, as if it were:
+ (lambda (proc arg1 . args) ...)
+ Thus, if you just have a list of arguments to pass to a procedure,
+ pass the list as ARG1, and '() for ARGS. If you have some fixed
+ args, pass the first as ARG1, then cons any remaining fixed args
+ onto the front of your argument list, and pass that as ARGS. */
+
+SCM
+SCM_APPLY (SCM proc, SCM arg1, SCM args)
+{
+#ifdef DEVAL
+ scm_t_debug_frame debug;
+ scm_t_debug_info debug_vect_body;
+ debug.prev = scm_i_last_debug_frame ();
+ debug.status = SCM_APPLYFRAME;
+ debug.vect = &debug_vect_body;
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = SCM_EOL;
+ scm_i_set_last_debug_frame (&debug);
+#else
+ if (scm_debug_mode_p)
+ return scm_dapply (proc, arg1, args);
+#endif
+
+ SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+ /* If ARGS is the empty list, then we're calling apply with only two
+ arguments --- ARG1 is the list of arguments for PROC. Whatever
+ the case, futz with things so that ARG1 is the first argument to
+ give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
+ rest.
+
+ Setting the debug apply frame args this way is pretty messy.
+ Perhaps we should store arg1 and args directly in the frame as
+ received, and let scm_frame_arguments unpack them, because that's
+ a relatively rare operation. This works for now; if the Guile
+ developer archives are still around, see Mikael's post of
+ 11-Apr-97. */
+ if (scm_is_null (args))
+ {
+ if (scm_is_null (arg1))
+ {
+ arg1 = SCM_UNDEFINED;
+#ifdef DEVAL
+ debug.vect[0].a.args = SCM_EOL;
+#endif
+ }
+ else
+ {
+#ifdef DEVAL
+ debug.vect[0].a.args = arg1;
+#endif
+ args = SCM_CDR (arg1);
+ arg1 = SCM_CAR (arg1);
+ }
+ }
+ else
+ {
+ args = scm_nconc2last (args);
+#ifdef DEVAL
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#endif
+ }
+#ifdef DEVAL
+ if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
+ {
+ SCM tmp = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
+ SCM_TRAPS_P = 1;
+ }
+ ENTER_APPLY;
+#endif
+tail:
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_2o:
+ if (SCM_UNBNDP (arg1))
+ scm_wrong_num_args (proc);
+ if (scm_is_null (args))
+ args = SCM_UNDEFINED;
+ else
+ {
+ if (! scm_is_null (SCM_CDR (args)))
+ scm_wrong_num_args (proc);
+ args = SCM_CAR (args);
+ }
+ RETURN (SCM_SUBRF (proc) (arg1, args));
+ case scm_tc7_subr_2:
+ if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
+ scm_wrong_num_args (proc);
+ args = SCM_CAR (args);
+ RETURN (SCM_SUBRF (proc) (arg1, args));
+ case scm_tc7_subr_0:
+ if (!SCM_UNBNDP (arg1))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) ());
+ case scm_tc7_subr_1:
+ if (SCM_UNBNDP (arg1))
+ scm_wrong_num_args (proc);
+ case scm_tc7_subr_1o:
+ if (!scm_is_null (args))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1));
+ case scm_tc7_dsubr:
+ if (SCM_UNBNDP (arg1) || !scm_is_null (args))
+ scm_wrong_num_args (proc);
+ if (SCM_I_INUMP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+ else if (SCM_FRACTIONP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
+ }
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
+ case scm_tc7_cxr:
+ if (SCM_UNBNDP (arg1) || !scm_is_null (args))
+ scm_wrong_num_args (proc);
+ RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
+ case scm_tc7_subr_3:
+ if (scm_is_null (args)
+ || scm_is_null (SCM_CDR (args))
+ || !scm_is_null (SCM_CDDR (args)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
+ case scm_tc7_lsubr:
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
+#endif
+ case scm_tc7_lsubr_2:
+ if (!scm_is_pair (args))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
+ case scm_tc7_asubr:
+ if (scm_is_null (args))
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ while (SCM_NIMP (args))
+ {
+ SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
+ arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
+ args = SCM_CDR (args);
+ }
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (scm_is_null (args))
+ RETURN (SCM_BOOL_T);
+ while (SCM_NIMP (args))
+ {
+ SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
+ if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
+ RETURN (SCM_BOOL_F);
+ arg1 = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+ RETURN (SCM_BOOL_T);
+ case scm_tcs_closures:
+#ifdef DEVAL
+ arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+ arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
+ scm_wrong_num_args (proc);
+
+ /* Copy argument list */
+ if (SCM_IMP (arg1))
+ args = arg1;
+ else
+ {
+ SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
+ for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
+ {
+ SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
+ tl = SCM_CDR (tl);
+ }
+ SCM_SETCDR (tl, arg1);
+ }
+
+ args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ args,
+ SCM_ENV (proc));
+ proc = SCM_CLOSURE_BODY (proc);
+ again:
+ arg1 = SCM_CDR (proc);
+ while (!scm_is_null (arg1))
+ {
+ if (SCM_IMP (SCM_CAR (proc)))
+ {
+ if (SCM_ISYMP (SCM_CAR (proc)))
+ {
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (proc)))
+ m_expand_body (proc, args);
+ scm_dynwind_end ();
+ goto again;
+ }
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
+ }
+ else
+ (void) EVAL (SCM_CAR (proc), args);
+ proc = arg1;
+ arg1 = SCM_CDR (proc);
+ }
+ RETURN (EVALCAR (proc, args));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badproc;
+ if (SCM_UNBNDP (arg1))
+ RETURN (SCM_SMOB_APPLY_0 (proc));
+ else if (scm_is_null (args))
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
+ else if (scm_is_null (SCM_CDR (args)))
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
+ else
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
+ case scm_tc7_cclo:
+#ifdef DEVAL
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#else
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+#endif
+ goto tail;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.vect[0].a.proc = proc;
+#endif
+ goto tail;
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+#ifdef DEVAL
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+ RETURN (scm_apply_generic (proc, args));
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ /* operator */
+#ifdef DEVAL
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+#ifdef DEVAL
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#endif
+ if (SCM_NIMP (proc))
+ goto tail;
+ else
+ goto badproc;
+ }
+ else
+ goto badproc;
+ default:
+ badproc:
+ scm_wrong_type_arg ("apply", SCM_ARG1, proc);
+ }
+#ifdef DEVAL
+exit:
+ if (scm_check_exit_p && SCM_TRAPS_P)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_CLEAR_TRACED_FRAME (debug);
+ arg1 = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
+ SCM_TRAPS_P = 1;
+ if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
+ proc = SCM_CDR (arg1);
+ }
+ scm_i_set_last_debug_frame (debug.prev);
+ return proc;
+#endif
+}
+
diff --git a/libguile/feature.c b/libguile/feature.c
index 1d44a7790..6cd0e54ab 100644
--- a/libguile/feature.c
+++ b/libguile/feature.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -76,6 +76,22 @@ scm_set_program_arguments (int argc, char **argv, char *first)
scm_fluid_set_x (progargs_fluid, args);
}
+SCM_DEFINE (scm_set_program_arguments_scm, "set-program-arguments", 1, 0, 0,
+ (SCM lst),
+ "Set the command line arguments to be returned by\n"
+ "@code{program-arguments} (and @code{command-line}). @var{lst}\n"
+ "should be a list of strings, the first of which is the program\n"
+ "name (either a script name, or just @code{\"guile\"}).\n"
+ "\n"
+ "Program arguments are held in a fluid and therefore have a\n"
+ "separate value in each Guile thread. Neither the list nor the\n"
+ "strings within it are copied, so should not be modified later.")
+#define FUNC_NAME s_scm_set_program_arguments_scm
+{
+ return scm_fluid_set_x (progargs_fluid, lst);
+}
+#undef FUNC_NAME
+
diff --git a/libguile/feature.h b/libguile/feature.h
index 58db46422..9c61f8ce8 100644
--- a/libguile/feature.h
+++ b/libguile/feature.h
@@ -3,7 +3,7 @@
#ifndef SCM_FEATURE_H
#define SCM_FEATURE_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -27,6 +27,7 @@
SCM_API void scm_add_feature (const char* str);
SCM_API SCM scm_program_arguments (void);
SCM_API void scm_set_program_arguments (int argc, char **argv, char *first);
+SCM_API SCM scm_set_program_arguments_scm (SCM lst);
SCM_API void scm_init_feature (void);
#endif /* SCM_FEATURE_H */
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 72b45e92a..1798bb698 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1681,65 +1681,65 @@ scm_init_filesys ()
scm_dot_string = scm_permanent_object (scm_from_locale_string ("."));
#ifdef O_RDONLY
- scm_c_define ("O_RDONLY", scm_from_long (O_RDONLY));
+ scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
#endif
#ifdef O_WRONLY
- scm_c_define ("O_WRONLY", scm_from_long (O_WRONLY));
+ scm_c_define ("O_WRONLY", scm_from_int (O_WRONLY));
#endif
#ifdef O_RDWR
- scm_c_define ("O_RDWR", scm_from_long (O_RDWR));
+ scm_c_define ("O_RDWR", scm_from_int (O_RDWR));
#endif
#ifdef O_CREAT
- scm_c_define ("O_CREAT", scm_from_long (O_CREAT));
+ scm_c_define ("O_CREAT", scm_from_int (O_CREAT));
#endif
#ifdef O_EXCL
- scm_c_define ("O_EXCL", scm_from_long (O_EXCL));
+ scm_c_define ("O_EXCL", scm_from_int (O_EXCL));
#endif
#ifdef O_NOCTTY
- scm_c_define ("O_NOCTTY", scm_from_long (O_NOCTTY));
+ scm_c_define ("O_NOCTTY", scm_from_int (O_NOCTTY));
#endif
#ifdef O_TRUNC
- scm_c_define ("O_TRUNC", scm_from_long (O_TRUNC));
+ scm_c_define ("O_TRUNC", scm_from_int (O_TRUNC));
#endif
#ifdef O_APPEND
- scm_c_define ("O_APPEND", scm_from_long (O_APPEND));
+ scm_c_define ("O_APPEND", scm_from_int (O_APPEND));
#endif
#ifdef O_NONBLOCK
- scm_c_define ("O_NONBLOCK", scm_from_long (O_NONBLOCK));
+ scm_c_define ("O_NONBLOCK", scm_from_int (O_NONBLOCK));
#endif
#ifdef O_NDELAY
- scm_c_define ("O_NDELAY", scm_from_long (O_NDELAY));
+ scm_c_define ("O_NDELAY", scm_from_int (O_NDELAY));
#endif
#ifdef O_SYNC
- scm_c_define ("O_SYNC", scm_from_long (O_SYNC));
+ scm_c_define ("O_SYNC", scm_from_int (O_SYNC));
#endif
#ifdef O_LARGEFILE
- scm_c_define ("O_LARGEFILE", scm_from_long (O_LARGEFILE));
+ scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
#endif
#ifdef F_DUPFD
- scm_c_define ("F_DUPFD", scm_from_long (F_DUPFD));
+ scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));
#endif
#ifdef F_GETFD
- scm_c_define ("F_GETFD", scm_from_long (F_GETFD));
+ scm_c_define ("F_GETFD", scm_from_int (F_GETFD));
#endif
#ifdef F_SETFD
- scm_c_define ("F_SETFD", scm_from_long (F_SETFD));
+ scm_c_define ("F_SETFD", scm_from_int (F_SETFD));
#endif
#ifdef F_GETFL
- scm_c_define ("F_GETFL", scm_from_long (F_GETFL));
+ scm_c_define ("F_GETFL", scm_from_int (F_GETFL));
#endif
#ifdef F_SETFL
- scm_c_define ("F_SETFL", scm_from_long (F_SETFL));
+ scm_c_define ("F_SETFL", scm_from_int (F_SETFL));
#endif
#ifdef F_GETOWN
- scm_c_define ("F_GETOWN", scm_from_long (F_GETOWN));
+ scm_c_define ("F_GETOWN", scm_from_int (F_GETOWN));
#endif
#ifdef F_SETOWN
- scm_c_define ("F_SETOWN", scm_from_long (F_SETOWN));
+ scm_c_define ("F_SETOWN", scm_from_int (F_SETOWN));
#endif
#ifdef FD_CLOEXEC
- scm_c_define ("FD_CLOEXEC", scm_from_long (FD_CLOEXEC));
+ scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC));
#endif
#include "libguile/filesys.x"
diff --git a/libguile/gc.c b/libguile/gc.c
index d8b27d2f5..3e8c02e1e 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -223,6 +223,7 @@ unsigned long scm_mtrigger;
/* GC Statistics Keeping
*/
unsigned long scm_cells_allocated = 0;
+unsigned long scm_last_cells_allocated = 0;
unsigned long scm_mallocated = 0;
unsigned long scm_gc_cells_collected;
unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */
@@ -256,8 +257,7 @@ SCM_SYMBOL (sym_cells_swept, "cells-swept");
SCM_SYMBOL (sym_malloc_yield, "malloc-yield");
SCM_SYMBOL (sym_cell_yield, "cell-yield");
SCM_SYMBOL (sym_protected_objects, "protected-objects");
-
-
+SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated");
/* Number of calls to SCM_NEWCELL since startup. */
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index c0bdd841e..356d771e8 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -24,6 +24,8 @@
#include "libguile/gsubr.h"
#include "libguile/deprecation.h"
+
+#include "libguile/private-options.h"
/*
* gsubr.c
diff --git a/libguile/i18n.c b/libguile/i18n.c
index 76dd9a514..e23f79072 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -46,6 +46,7 @@ void *alloca (size_t);
#include "libguile/dynwind.h"
#include "libguile/validate.h"
#include "libguile/values.h"
+#include "libguile/threads.h"
#include <locale.h>
#include <string.h> /* `strcoll ()' */
@@ -53,11 +54,29 @@ void *alloca (size_t);
#include <errno.h>
#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
+/* The GNU thread-aware locale API is documented in ``Thread-Aware Locale
+ Model, a Proposal'', by Ulrich Drepper:
+
+ http://people.redhat.com/drepper/tllocale.ps.gz
+
+ It is now also implemented by Darwin:
+
+ http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html
+
+ The whole API is being standardized by the X/Open Group (as of Jan. 2007)
+ following Drepper's proposal. */
# define USE_GNU_LOCALE_API
#endif
-#ifndef USE_GNU_LOCALE_API
-# include "libguile/posix.h" /* for `scm_i_locale_mutex' */
+#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
+# include <xlocale.h>
+#endif
+
+#include "libguile/posix.h" /* for `scm_i_locale_mutex' */
+
+#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H)
+# include <langinfo.h>
+# include <nl_types.h>
#endif
#ifndef HAVE_SETLOCALE
@@ -69,6 +88,9 @@ setlocale (int category, const char *name)
}
#endif
+/* Helper stringification macro. */
+#define SCM_I18N_STRINGIFY(_name) # _name
+
/* Locale objects, string and character collation, and other locale-dependent
@@ -78,18 +100,16 @@ setlocale (int category, const char *name)
locale API on non-GNU systems. The emulation is a bit "brute-force":
Whenever a `-locale<?' procedure is passed a locale object, then:
- 1. The `scm_t_locale_mutex' is locked.
+ 1. The `scm_i_locale_mutex' is locked.
2. A series of `setlocale ()' call is performed to store the current
- locale for each category in an `scm_t_locale_settings' object.
+ locale for each category in an `scm_t_locale' object.
3. A series of `setlocale ()' call is made to install each of the locale
categories of each of the base locales of each locale object,
recursively, starting from the last locale object of the chain.
4. The settings captured in step (2) are restored.
- 5. The `scm_t_locale_mutex' is released.
+ 5. The `scm_i_locale_mutex' is released.
- Hopefully, some smart standard will make that hack useless someday...
- A similar API can be found in MzScheme starting from version 200:
- http://download.plt-scheme.org/chronology/mzmr200alpha14.html .
+ Hopefully, the X/Open standard will eventually make this hack useless.
Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
of the current _thread_ (unlike `setlocale ()') and doing so would require
@@ -97,62 +117,65 @@ setlocale (int category, const char *name)
re-installing this locale upon locale-dependent calls. */
+/* Return the category mask corresponding to CAT. */
+#define SCM_LOCALE_CATEGORY_MASK(_cat) LC_ ## _cat ## _MASK
+
+
#ifndef USE_GNU_LOCALE_API
-/* Provide the locale category masks as found in glibc (copied from
- <locale.h> as found in glibc 2.3.6). This must be kept in sync with
- `locale-categories.h'. */
+/* Provide the locale category masks as found in glibc. This must be kept in
+ sync with `locale-categories.h'. */
-# define LC_CTYPE_MASK (1 << LC_CTYPE)
-# define LC_COLLATE_MASK (1 << LC_COLLATE)
-# define LC_MESSAGES_MASK (1 << LC_MESSAGES)
-# define LC_MONETARY_MASK (1 << LC_MONETARY)
-# define LC_NUMERIC_MASK (1 << LC_NUMERIC)
-# define LC_TIME_MASK (1 << LC_TIME)
+# define LC_CTYPE_MASK 1
+# define LC_COLLATE_MASK 2
+# define LC_MESSAGES_MASK 4
+# define LC_MONETARY_MASK 8
+# define LC_NUMERIC_MASK 16
+# define LC_TIME_MASK 32
# ifdef LC_PAPER
-# define LC_PAPER_MASK (1 << LC_PAPER)
+# define LC_PAPER_MASK 64
# else
# define LC_PAPER_MASK 0
# endif
# ifdef LC_NAME
-# define LC_NAME_MASK (1 << LC_NAME)
+# define LC_NAME_MASK 128
# else
# define LC_NAME_MASK 0
# endif
# ifdef LC_ADDRESS
-# define LC_ADDRESS_MASK (1 << LC_ADDRESS)
+# define LC_ADDRESS_MASK 256
# else
# define LC_ADDRESS_MASK 0
# endif
# ifdef LC_TELEPHONE
-# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE)
+# define LC_TELEPHONE_MASK 512
# else
# define LC_TELEPHONE_MASK 0
# endif
# ifdef LC_MEASUREMENT
-# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT)
+# define LC_MEASUREMENT_MASK 1024
# else
# define LC_MEASUREMENT_MASK 0
# endif
# ifdef LC_IDENTIFICATION
-# define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION)
+# define LC_IDENTIFICATION_MASK 2048
# else
# define LC_IDENTIFICATION_MASK 0
# endif
-# define LC_ALL_MASK (LC_CTYPE_MASK \
- | LC_NUMERIC_MASK \
- | LC_TIME_MASK \
- | LC_COLLATE_MASK \
- | LC_MONETARY_MASK \
- | LC_MESSAGES_MASK \
- | LC_PAPER_MASK \
- | LC_NAME_MASK \
- | LC_ADDRESS_MASK \
- | LC_TELEPHONE_MASK \
- | LC_MEASUREMENT_MASK \
- | LC_IDENTIFICATION_MASK \
+# define LC_ALL_MASK (LC_CTYPE_MASK \
+ | LC_NUMERIC_MASK \
+ | LC_TIME_MASK \
+ | LC_COLLATE_MASK \
+ | LC_MONETARY_MASK \
+ | LC_MESSAGES_MASK \
+ | LC_PAPER_MASK \
+ | LC_NAME_MASK \
+ | LC_ADDRESS_MASK \
+ | LC_TELEPHONE_MASK \
+ | LC_MEASUREMENT_MASK \
+ | LC_IDENTIFICATION_MASK \
)
/* Locale objects as returned by `make-locale' on non-GNU systems. */
@@ -163,12 +186,28 @@ typedef struct scm_locale
int category_mask;
} *scm_t_locale;
-#else
+
+/* Free the resources used by LOCALE. */
+static inline void
+scm_i_locale_free (scm_t_locale locale)
+{
+ free (locale->locale_name);
+ locale->locale_name = NULL;
+}
+
+#else /* USE_GNU_LOCALE_API */
/* Alias for glibc's locale type. */
typedef locale_t scm_t_locale;
-#endif
+#define scm_i_locale_free freelocale
+
+#endif /* USE_GNU_LOCALE_API */
+
+
+/* A locale object denoting the global locale. */
+SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");
+
/* Validate parameter ARG as a locale object and set C_LOCALE to the
corresponding C locale object. */
@@ -199,16 +238,8 @@ SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
{
scm_t_locale c_locale;
- c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
-
-#ifdef USE_GNU_LOCALE_API
- freelocale ((locale_t)c_locale);
-#else
- c_locale->base_locale = SCM_UNDEFINED;
- free (c_locale->locale_name);
-
- scm_gc_free (c_locale, sizeof (* c_locale), "locale");
-#endif
+ c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
+ scm_i_locale_free (c_locale);
return 0;
}
@@ -217,76 +248,38 @@ SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
static SCM
smob_locale_mark (SCM locale)
{
- scm_t_locale c_locale;
-
- c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
- return (c_locale->base_locale);
-}
-#endif
-
+ register SCM dependency;
-SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
- (SCM category_mask, SCM locale_name, SCM base_locale),
- "Return a reference to a data structure representing a set of "
- "locale datasets. Unlike for the @var{category} parameter for "
- "@code{setlocale}, the @var{category_mask} parameter here uses "
- "a single bit for each category, made by OR'ing together "
- "@code{LC_*_MASK} bits.")
-#define FUNC_NAME s_scm_make_locale
-{
- SCM locale = SCM_BOOL_F;
- int c_category_mask;
- char *c_locale_name;
- scm_t_locale c_base_locale, c_locale;
-
- SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask);
- SCM_VALIDATE_STRING (2, locale_name);
- SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);
-
- c_locale_name = scm_to_locale_string (locale_name);
-
-#ifdef USE_GNU_LOCALE_API
-
- c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
+ if (!scm_is_eq (locale, SCM_VARIABLE_REF (scm_global_locale)))
+ {
+ scm_t_locale c_locale;
- if (!c_locale)
- locale = SCM_BOOL_F;
+ c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
+ dependency = (c_locale->base_locale);
+ }
else
- SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
-
- free (c_locale_name);
-
-#else
-
- c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
- c_locale->base_locale = base_locale;
-
- c_locale->category_mask = c_category_mask;
- c_locale->locale_name = c_locale_name;
-
- SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
+ dependency = SCM_BOOL_F;
+ return dependency;
+}
#endif
- return locale;
-}
-#undef FUNC_NAME
-SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
- (SCM obj),
- "Return true if @var{obj} is a locale object.")
-#define FUNC_NAME s_scm_locale_p
-{
- if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj))
- return SCM_BOOL_T;
+static void inline scm_locale_error (const char *, int) SCM_NORETURN;
- return SCM_BOOL_F;
+/* Throw an exception corresponding to error ERR. */
+static void inline
+scm_locale_error (const char *func_name, int err)
+{
+ scm_syserror_msg (func_name,
+ "Failed to install locale",
+ SCM_EOL, err);
}
-#undef FUNC_NAME
-#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */
+/* Emulating GNU's reentrant locale API. */
+#ifndef USE_GNU_LOCALE_API
/* Maximum number of chained locales (via `base_locale'). */
@@ -309,7 +302,7 @@ get_current_locale_settings (scm_t_locale_settings *settings)
#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
{ \
SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
- if (!locale_name) \
+ if (locale_name == NULL) \
goto handle_error; \
\
settings-> _name = strdup (locale_name); \
@@ -323,7 +316,7 @@ get_current_locale_settings (scm_t_locale_settings *settings)
return 0;
handle_error:
- return errno;
+ return EINVAL;
handle_oom:
return ENOMEM;
@@ -346,7 +339,7 @@ restore_locale_settings (const scm_t_locale_settings *settings)
return 0;
handle_error:
- return errno;
+ return EINVAL;
}
/* Free memory associated with SETTINGS. */
@@ -376,7 +369,7 @@ install_locale_categories (const char *locale_name, int category_mask)
else
{
#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
- if (category_mask & LC_ ## _name ## _MASK) \
+ if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \
{ \
SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \
if (result == NULL) \
@@ -389,7 +382,7 @@ install_locale_categories (const char *locale_name, int category_mask)
return 0;
handle_error:
- return errno;
+ return EINVAL;
}
/* Install LOCALE, recursively installing its base locales first. On
@@ -398,6 +391,7 @@ static int
install_locale (scm_t_locale locale)
{
scm_t_locale stack[LOCALE_STACK_SIZE_MAX];
+ int category_mask = 0;
size_t stack_size = 0;
int stack_offset = 0;
const char *result = NULL;
@@ -412,12 +406,16 @@ install_locale (scm_t_locale locale)
stack[stack_size++] = locale;
+ /* Keep track of which categories have already been taken into
+ account. */
+ category_mask |= locale->category_mask;
+
if (locale->base_locale != SCM_UNDEFINED)
- locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale);
+ locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
else
locale = NULL;
}
- while (locale != NULL);
+ while ((locale != NULL) && (category_mask != LC_ALL_MASK));
/* Install the C locale to start from a pristine state. */
SCM_SYSCALL (result = setlocale (LC_ALL, "C"));
@@ -442,7 +440,7 @@ install_locale (scm_t_locale locale)
return 0;
handle_error:
- return errno;
+ return EINVAL;
}
/* Leave the locked locale section. */
@@ -481,19 +479,6 @@ enter_locale_section (scm_t_locale locale,
return err;
}
-/* Throw an exception corresponding to error ERR. */
-static void inline
-scm_locale_error (const char *func_name, int err)
-{
- SCM s_err;
-
- s_err = scm_from_int (err);
- scm_error (scm_system_error_key, func_name,
- "Failed to install locale",
- scm_cons (scm_strerror (s_err), SCM_EOL),
- scm_cons (s_err, SCM_EOL));
-}
-
/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
#define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
do \
@@ -514,10 +499,248 @@ scm_locale_error (const char *func_name, int err)
} \
while (0)
+/* Convert the current locale settings into a locale SMOB. On success, zero
+ is returned and RESULT points to the new SMOB. Otherwise, an error is
+ returned. */
+static int
+get_current_locale (SCM *result)
+{
+ int err = 0;
+ scm_t_locale c_locale;
+ const char *current_locale;
+
+ c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
+
+
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+
+ c_locale->category_mask = LC_ALL_MASK;
+ c_locale->base_locale = SCM_UNDEFINED;
+
+ current_locale = setlocale (LC_ALL, NULL);
+ if (current_locale != NULL)
+ {
+ c_locale->locale_name = strdup (current_locale);
+ if (c_locale->locale_name == NULL)
+ err = ENOMEM;
+ }
+ else
+ err = EINVAL;
+
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
+ if (err)
+ scm_gc_free (c_locale, sizeof (* c_locale), "locale");
+ else
+ SCM_NEWSMOB (*result, scm_tc16_locale_smob_type, c_locale);
+
+ return err;
+}
+
+
#endif /* !USE_GNU_LOCALE_API */
+
+
+/* `make-locale' can take either category lists or single categories (the
+ `LC_*' integer constants). */
+#define SCM_LIST_OR_INTEGER_P(arg) \
+ (scm_is_integer (arg) || scm_is_true (scm_list_p (arg)))
+
+
+/* Return the category mask corresponding to CATEGORY (an `LC_' integer
+ constant). */
+static inline int
+category_to_category_mask (SCM category,
+ const char *func_name, int pos)
+{
+ int c_category;
+ int c_category_mask;
+
+ c_category = scm_to_int (category);
+
+#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
+ case LC_ ## _name: \
+ c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name); \
+ break;
+
+ switch (c_category)
+ {
+#include "locale-categories.h"
+
+ case LC_ALL:
+ c_category_mask = LC_ALL_MASK;
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (func_name, pos, category,
+ "locale category");
+ }
+
+#undef SCM_DEFINE_LOCALE_CATEGORY
+
+ return c_category_mask;
+}
+
+/* Convert CATEGORIES, a list of locale categories or a single category (an
+ integer), into a category mask. */
+static int
+category_list_to_category_mask (SCM categories,
+ const char *func_name, int pos)
+{
+ int c_category_mask = 0;
+
+ if (scm_is_integer (categories))
+ c_category_mask = category_to_category_mask (categories,
+ func_name, pos);
+ else
+ for (; !scm_is_null (categories); categories = SCM_CDR (categories))
+ {
+ SCM category = SCM_CAR (categories);
+
+ c_category_mask |=
+ category_to_category_mask (category, func_name, pos);
+ }
+
+ return c_category_mask;
+}
+
+
+SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
+ (SCM category_list, SCM locale_name, SCM base_locale),
+ "Return a reference to a data structure representing a set of "
+ "locale datasets. @var{category_list} should be either a list "
+ "of locale categories or a single category as used with "
+ "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and "
+ "@var{locale_name} should be the name of the locale considered "
+ "(e.g., @code{\"sl_SI\"}). Optionally, if @code{base_locale} is "
+ "passed, it should be a locale object denoting settings for "
+ "categories not listed in @var{category_list}.")
+#define FUNC_NAME s_scm_make_locale
+{
+ SCM locale = SCM_BOOL_F;
+ int err = 0;
+ int c_category_mask;
+ char *c_locale_name;
+ scm_t_locale c_base_locale, c_locale;
+
+ SCM_MAKE_VALIDATE (1, category_list, LIST_OR_INTEGER_P);
+ SCM_VALIDATE_STRING (2, locale_name);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);
+
+ c_category_mask = category_list_to_category_mask (category_list,
+ FUNC_NAME, 1);
+ c_locale_name = scm_to_locale_string (locale_name);
+
+#ifdef USE_GNU_LOCALE_API
+
+ if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
+ {
+ /* Fetch the current locale and turn in into a `locale_t'. Don't
+ duplicate the resulting `locale_t' because we want it to be consumed
+ by `newlocale ()'. */
+ char *current_locale;
+
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+
+ current_locale = setlocale (LC_ALL, NULL);
+ c_base_locale = newlocale (LC_ALL_MASK, current_locale, NULL);
+
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
+ if (c_base_locale == (locale_t) 0)
+ scm_locale_error (FUNC_NAME, errno);
+ }
+ else if (c_base_locale != (locale_t) 0)
+ {
+ /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be
+ duplicated before. */
+ c_base_locale = duplocale (c_base_locale);
+ if (c_base_locale == (locale_t) 0)
+ {
+ err = errno;
+ goto fail;
+ }
+ }
+
+ c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
+
+ free (c_locale_name);
+
+ if (c_locale == (locale_t) 0)
+ {
+ if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
+ /* The base locale object was created lazily and must be freed. */
+ freelocale (c_base_locale);
+
+ scm_locale_error (FUNC_NAME, errno);
+ }
+ else
+ SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
+
+#else
+
+ c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
+
+ c_locale->category_mask = c_category_mask;
+ c_locale->locale_name = c_locale_name;
+
+ if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
+ {
+ /* Get the current locale settings and turn them into a locale
+ object. */
+ err = get_current_locale (&base_locale);
+ if (err)
+ goto fail;
+ }
+
+ c_locale->base_locale = base_locale;
+
+ {
+ /* Try out the new locale and raise an exception if it doesn't work. */
+ int err;
+ scm_t_locale_settings prev_locale;
+
+ err = enter_locale_section (c_locale, &prev_locale);
+ leave_locale_section (&prev_locale);
+
+ if (err)
+ goto fail;
+ else
+ SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
+ }
+
+#endif
+
+ return locale;
+
+ fail:
+#ifndef USE_GNU_LOCALE_API
+ scm_gc_free (c_locale, sizeof (* c_locale), "locale");
+#endif
+ free (c_locale_name);
+ scm_locale_error (FUNC_NAME, err);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a locale object.")
+#define FUNC_NAME s_scm_locale_p
+{
+ return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj));
+}
+#undef FUNC_NAME
+
+
-/* Locale-dependent string comparison. */
+/* Locale-dependent string comparison.
+
+ A similar API can be found in MzScheme starting from version 200:
+ http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
+
/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return
an integer whose sign is the same as the difference between C_S1 and
@@ -1124,33 +1347,388 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
}
#undef FUNC_NAME
-
-void
-scm_init_i18n ()
+/* Language information, aka. `nl_langinfo ()'. */
+
+/* FIXME: Issues related to `nl-langinfo'.
+
+ 1. The `CODESET' value is not normalized. This is a secondary issue, but
+ still a practical issue. See
+ http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
+ normalization.
+
+ 2. `nl_langinfo ()' is not available on Windows.
+
+ 3. `nl_langinfo ()' may return strings encoded in a locale different from
+ the current one, thereby defeating `scm_from_locale_string ()'.
+ Example: support the current locale is "Latin-1" and one asks:
+
+ (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
+
+ The result will be a UTF-8 string. However, `scm_from_locale_string',
+ which expects a Latin-1 string, won't be able to make much sense of the
+ returned string. Thus, we'd need an `scm_from_string ()' variant where
+ the locale (or charset) is explicitly passed. */
+
+
+SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
+ (SCM item, SCM locale),
+ "Return a string denoting locale information for @var{item} "
+ "in the current locale or that specified by @var{locale}. "
+ "The semantics and arguments are the same as those of the "
+ "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
+ "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
+ "Reference Manual}).")
+#define FUNC_NAME s_scm_nl_langinfo
+{
+#ifdef HAVE_NL_LANGINFO
+ SCM result;
+ nl_item c_item;
+ char *c_result;
+ scm_t_locale c_locale;
+
+ SCM_VALIDATE_INT_COPY (2, item, c_item);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+
+ /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According
+ to SuS v2, that static string may be modified by subsequent calls to
+ `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must
+ acquire the locale mutex before doing invoking `nl_langinfo ()'. See
+ http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
+ details. */
+
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+ if (c_locale != NULL)
+ {
+#ifdef USE_GNU_LOCALE_API
+ c_result = nl_langinfo_l (c_item, c_locale);
+#else
+ /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
+ mutex is already taken. */
+ int lsec_err;
+ scm_t_locale_settings lsec_prev_locale;
+
+ lsec_err = get_current_locale_settings (&lsec_prev_locale);
+ if (lsec_err)
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+ else
+ {
+ lsec_err = install_locale (c_locale);
+ if (lsec_err)
+ {
+ leave_locale_section (&lsec_prev_locale);
+ free_locale_settings (&lsec_prev_locale);
+ }
+ }
+
+ if (lsec_err)
+ scm_locale_error (FUNC_NAME, lsec_err);
+ else
+ {
+ c_result = nl_langinfo (c_item);
+
+ leave_locale_section (&lsec_prev_locale);
+ free_locale_settings (&lsec_prev_locale);
+ }
+#endif
+ }
+ else
+ c_result = nl_langinfo (c_item);
+
+ c_result = strdup (c_result);
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
+ if (c_result == NULL)
+ result = SCM_BOOL_F;
+ else
+ {
+ char *p;
+
+ switch (c_item)
+ {
+ case GROUPING:
+ case MON_GROUPING:
+ /* In this cases, the result is to be interpreted as a list of
+ numbers. If the last item is `CHARS_MAX', it has the special
+ meaning "no more grouping". */
+ result = SCM_EOL;
+ for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
+ result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
+
+ {
+ SCM last_pair = result;
+
+ result = scm_reverse_x (result, SCM_EOL);
+
+ if (*p != CHAR_MAX)
+ {
+ /* Cyclic grouping information. */
+ if (last_pair != SCM_EOL)
+ SCM_SETCDR (last_pair, result);
+ }
+ }
+
+ free (c_result);
+ break;
+
+ case FRAC_DIGITS:
+ case INT_FRAC_DIGITS:
+ /* This is to be interpreted as a single integer. */
+ if (*c_result == CHAR_MAX)
+ /* Unspecified. */
+ result = SCM_BOOL_F;
+ else
+ result = SCM_I_MAKINUM (*c_result);
+
+ free (c_result);
+ break;
+
+ case P_CS_PRECEDES:
+ case N_CS_PRECEDES:
+ case INT_P_CS_PRECEDES:
+ case INT_N_CS_PRECEDES:
+ case P_SEP_BY_SPACE:
+ case N_SEP_BY_SPACE:
+ /* This is to be interpreted as a boolean. */
+ result = scm_from_bool (*c_result);
+
+ free (c_result);
+ break;
+
+ case P_SIGN_POSN:
+ case N_SIGN_POSN:
+ case INT_P_SIGN_POSN:
+ case INT_N_SIGN_POSN:
+ /* See `(libc) Sign of Money Amount' for the interpretation of the
+ return value here. */
+ switch (*c_result)
+ {
+ case 0:
+ result = scm_from_locale_symbol ("parenthesize");
+ break;
+
+ case 1:
+ result = scm_from_locale_symbol ("sign-before");
+ break;
+
+ case 2:
+ result = scm_from_locale_symbol ("sign-after");
+ break;
+
+ case 3:
+ result = scm_from_locale_symbol ("sign-before-currency-symbol");
+ break;
+
+ case 4:
+ result = scm_from_locale_symbol ("sign-after-currency-symbol");
+ break;
+
+ default:
+ result = scm_from_locale_symbol ("unspecified");
+ }
+ break;
+
+ default:
+ /* FIXME: `locale_string ()' is not appropriate here because of
+ encoding issues (see comment above). */
+ result = scm_take_locale_string (c_result);
+ }
+ }
+
+ return result;
+#else
+ scm_syserror_msg (FUNC_NAME, "`nl-langinfo' not supported on your system",
+ SCM_EOL, ENOSYS);
+
+ return SCM_BOOL_F;
+#endif
+}
+#undef FUNC_NAME
+
+/* Define the `nl_item' constants. */
+static inline void
+define_langinfo_items (void)
{
- scm_add_feature ("ice-9-i18n");
+#if (defined HAVE_NL_TYPES_H) && (defined HAVE_LANGINFO_H)
+
+#define DEFINE_NLITEM_CONSTANT(_item) \
+ scm_c_define (# _item, scm_from_int (_item))
+
+ DEFINE_NLITEM_CONSTANT (CODESET);
+
+ /* Abbreviated days of the week. */
+ DEFINE_NLITEM_CONSTANT (ABDAY_1);
+ DEFINE_NLITEM_CONSTANT (ABDAY_2);
+ DEFINE_NLITEM_CONSTANT (ABDAY_3);
+ DEFINE_NLITEM_CONSTANT (ABDAY_4);
+ DEFINE_NLITEM_CONSTANT (ABDAY_5);
+ DEFINE_NLITEM_CONSTANT (ABDAY_6);
+ DEFINE_NLITEM_CONSTANT (ABDAY_7);
+
+ /* Long-named days of the week. */
+ DEFINE_NLITEM_CONSTANT (DAY_1); /* Sunday */
+ DEFINE_NLITEM_CONSTANT (DAY_2); /* Monday */
+ DEFINE_NLITEM_CONSTANT (DAY_3); /* Tuesday */
+ DEFINE_NLITEM_CONSTANT (DAY_4); /* Wednesday */
+ DEFINE_NLITEM_CONSTANT (DAY_5); /* Thursday */
+ DEFINE_NLITEM_CONSTANT (DAY_6); /* Friday */
+ DEFINE_NLITEM_CONSTANT (DAY_7); /* Saturday */
+
+ /* Abbreviated month names. */
+ DEFINE_NLITEM_CONSTANT (ABMON_1); /* Jan */
+ DEFINE_NLITEM_CONSTANT (ABMON_2);
+ DEFINE_NLITEM_CONSTANT (ABMON_3);
+ DEFINE_NLITEM_CONSTANT (ABMON_4);
+ DEFINE_NLITEM_CONSTANT (ABMON_5);
+ DEFINE_NLITEM_CONSTANT (ABMON_6);
+ DEFINE_NLITEM_CONSTANT (ABMON_7);
+ DEFINE_NLITEM_CONSTANT (ABMON_8);
+ DEFINE_NLITEM_CONSTANT (ABMON_9);
+ DEFINE_NLITEM_CONSTANT (ABMON_10);
+ DEFINE_NLITEM_CONSTANT (ABMON_11);
+ DEFINE_NLITEM_CONSTANT (ABMON_12);
+
+ /* Long month names. */
+ DEFINE_NLITEM_CONSTANT (MON_1); /* January */
+ DEFINE_NLITEM_CONSTANT (MON_2);
+ DEFINE_NLITEM_CONSTANT (MON_3);
+ DEFINE_NLITEM_CONSTANT (MON_4);
+ DEFINE_NLITEM_CONSTANT (MON_5);
+ DEFINE_NLITEM_CONSTANT (MON_6);
+ DEFINE_NLITEM_CONSTANT (MON_7);
+ DEFINE_NLITEM_CONSTANT (MON_8);
+ DEFINE_NLITEM_CONSTANT (MON_9);
+ DEFINE_NLITEM_CONSTANT (MON_10);
+ DEFINE_NLITEM_CONSTANT (MON_11);
+ DEFINE_NLITEM_CONSTANT (MON_12);
+
+ DEFINE_NLITEM_CONSTANT (AM_STR); /* Ante meridiem string. */
+ DEFINE_NLITEM_CONSTANT (PM_STR); /* Post meridiem string. */
+
+ DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime. */
+ DEFINE_NLITEM_CONSTANT (D_FMT); /* Date format for strftime. */
+ DEFINE_NLITEM_CONSTANT (T_FMT); /* Time format for strftime. */
+ DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime. */
+
+ DEFINE_NLITEM_CONSTANT (ERA); /* Alternate era. */
+ DEFINE_NLITEM_CONSTANT (ERA_D_FMT); /* Date in alternate era format. */
+ DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era
+ format. */
+ DEFINE_NLITEM_CONSTANT (ERA_T_FMT); /* Time in alternate era format. */
+
+ DEFINE_NLITEM_CONSTANT (ALT_DIGITS); /* Alternate symbols for digits. */
+ DEFINE_NLITEM_CONSTANT (RADIXCHAR);
+ DEFINE_NLITEM_CONSTANT (THOUSEP);
+
+#ifdef YESEXPR
+ DEFINE_NLITEM_CONSTANT (YESEXPR);
+#endif
+#ifdef NOEXPR
+ DEFINE_NLITEM_CONSTANT (NOEXPR);
+#endif
-#define _SCM_STRINGIFY_LC(_name) # _name
-#define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name)
+#ifdef CRNCYSTR /* currency symbol */
+ DEFINE_NLITEM_CONSTANT (CRNCYSTR);
+#endif
- /* Define all the relevant `_MASK' variables. */
-#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
- scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \
- SCM_I_MAKINUM (LC_ ## _name ## _MASK));
-#include "locale-categories.h"
+ /* GNU extensions. */
-#undef SCM_DEFINE_LOCALE_CATEGORY
-#undef SCM_STRINGIFY_LC
-#undef _SCM_STRINGIFY_LC
+#ifdef ERA_YEAR
+ DEFINE_NLITEM_CONSTANT (ERA_YEAR); /* Year in alternate era format. */
+#endif
- scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK));
+ /* LC_MONETARY category: formatting of monetary quantities.
+ These items each correspond to a member of `struct lconv',
+ defined in <locale.h>. */
+#ifdef INT_CURR_SYMBOL
+ DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL);
+#endif
+#ifdef MON_DECIMAL_POINT
+ DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT);
+#endif
+#ifdef MON_THOUSANDS_SEP
+ DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP);
+#endif
+#ifdef MON_GROUPING
+ DEFINE_NLITEM_CONSTANT (MON_GROUPING);
+#endif
+#ifdef POSITIVE_SIGN
+ DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN);
+#endif
+#ifdef NEGATIVE_SIGN
+ DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN);
+#endif
+#ifdef GROUPING
+ DEFINE_NLITEM_CONSTANT (GROUPING);
+#endif
+#ifdef INT_FRAC_DIGITS
+ DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS);
+#endif
+#ifdef FRAC_DIGITS
+ DEFINE_NLITEM_CONSTANT (FRAC_DIGITS);
+#endif
+#ifdef P_CS_PRECEDES
+ DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES);
+#endif
+#ifdef P_SEP_BY_SPACE
+ DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE);
+#endif
+#ifdef N_CS_PRECEDES
+ DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES);
+#endif
+#ifdef N_SEP_BY_SPACE
+ DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE);
+#endif
+#ifdef P_SIGN_POSN
+ DEFINE_NLITEM_CONSTANT (P_SIGN_POSN);
+#endif
+#ifdef N_SIGN_POSN
+ DEFINE_NLITEM_CONSTANT (N_SIGN_POSN);
+#endif
+#ifdef INT_P_CS_PRECEDES
+ DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES);
+#endif
+#ifdef INT_P_SEP_BY_SPACE
+ DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE);
+#endif
+#ifdef INT_N_CS_PRECEDES
+ DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES);
+#endif
+#ifdef INT_N_SEP_BY_SPACE
+ DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE);
+#endif
+#ifdef INT_P_SIGN_POSN
+ DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN);
+#endif
+#ifdef INT_N_SIGN_POSN
+ DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN);
+#endif
+
+#undef DEFINE_NLITEM_CONSTANT
+
+#endif /* HAVE_NL_TYPES_H */
+}
+
+
+void
+scm_init_i18n ()
+{
+ SCM global_locale_smob;
+
+#ifdef HAVE_NL_LANGINFO
+ scm_add_feature ("nl-langinfo");
+ define_langinfo_items ();
+#endif
#include "libguile/i18n.x"
#ifndef USE_GNU_LOCALE_API
scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark);
#endif
+
+ /* Initialize the global locale object with a special `locale' SMOB. */
+ SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
+ SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
}
diff --git a/libguile/i18n.h b/libguile/i18n.h
index 7d5d9baa9..17dc240d8 100644
--- a/libguile/i18n.h
+++ b/libguile/i18n.h
@@ -22,6 +22,7 @@
#include "libguile/__scm.h"
+SCM_API SCM scm_global_locale;
SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale);
SCM_API SCM scm_locale_p (SCM obj);
SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale);
@@ -40,6 +41,7 @@ SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale);
SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale);
SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale);
SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale);
+SCM_API SCM scm_nl_langinfo (SCM item, SCM locale);
SCM_API void scm_init_i18n (void);
diff --git a/libguile/init.c b/libguile/init.c
index 664aee63a..b65bc17cb 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -127,6 +127,7 @@
#include "libguile/deprecated.h"
#include "libguile/init.h"
+#include "libguile/private-options.h"
#ifdef HAVE_STRING_H
#include <string.h>
diff --git a/libguile/macros.c b/libguile/macros.c
index f46d0b434..1e2a12ef6 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -30,6 +30,8 @@
#include "libguile/validate.h"
#include "libguile/macros.h"
+#include "libguile/private-options.h"
+
scm_t_bits scm_tc16_macro;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 3be5314e0..a8c8996fa 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -452,28 +452,21 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
/* No, it's a proper fraction.
*/
- return scm_double_cell (scm_tc16_fraction,
- SCM_UNPACK (numerator),
- SCM_UNPACK (denominator), 0);
+ {
+ SCM divisor = scm_gcd (numerator, denominator);
+ if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1))))
+ {
+ numerator = scm_divide (numerator, divisor);
+ denominator = scm_divide (denominator, divisor);
+ }
+
+ return scm_double_cell (scm_tc16_fraction,
+ SCM_UNPACK (numerator),
+ SCM_UNPACK (denominator), 0);
+ }
}
#undef FUNC_NAME
-static void scm_i_fraction_reduce (SCM z)
-{
- if (!(SCM_FRACTION_REDUCED (z)))
- {
- SCM divisor;
- divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z));
- if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1))))
- {
- /* is this safe? */
- SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor));
- SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor));
- }
- SCM_FRACTION_REDUCED_SET (z);
- }
-}
-
double
scm_i_fraction2double (SCM z)
{
@@ -2387,7 +2380,6 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
}
else if (SCM_FRACTIONP (n))
{
- scm_i_fraction_reduce (n);
return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
scm_from_locale_string ("/"),
scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
@@ -2441,7 +2433,6 @@ int
scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
SCM str;
- scm_i_fraction_reduce (sexp);
str = scm_number_to_string (sexp, SCM_UNDEFINED);
scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port);
scm_remember_upto_here_1 (str);
@@ -3109,8 +3100,6 @@ scm_complex_equalp (SCM x, SCM y)
SCM
scm_i_fraction_equalp (SCM x, SCM y)
{
- scm_i_fraction_reduce (x);
- scm_i_fraction_reduce (y);
if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_NUMERATOR (y)))
|| scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
@@ -4492,7 +4481,12 @@ scm_product (SCM x, SCM y)
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
- return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x));
+ {
+ /* inexact*exact0 => exact 0, per R5RS "Exactness" section */
+ if (scm_is_eq (y, SCM_INUM0))
+ return y;
+ return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x));
+ }
else if (SCM_BIGP (y))
{
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
@@ -4512,8 +4506,13 @@ scm_product (SCM x, SCM y)
else if (SCM_COMPLEXP (x))
{
if (SCM_I_INUMP (y))
- return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x),
- SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x));
+ {
+ /* inexact*exact0 => exact 0, per R5RS "Exactness" section */
+ if (scm_is_eq (y, SCM_INUM0))
+ return y;
+ return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x),
+ SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x));
+ }
else if (SCM_BIGP (y))
{
double z = mpz_get_d (SCM_I_BIG_MPZ (y));
@@ -5425,10 +5424,7 @@ scm_numerator (SCM z)
else if (SCM_BIGP (z))
return z;
else if (SCM_FRACTIONP (z))
- {
- scm_i_fraction_reduce (z);
- return SCM_FRACTION_NUMERATOR (z);
- }
+ return SCM_FRACTION_NUMERATOR (z);
else if (SCM_REALP (z))
return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
else
@@ -5447,10 +5443,7 @@ scm_denominator (SCM z)
else if (SCM_BIGP (z))
return SCM_I_MAKINUM (1);
else if (SCM_FRACTIONP (z))
- {
- scm_i_fraction_reduce (z);
- return SCM_FRACTION_DENOMINATOR (z);
- }
+ return SCM_FRACTION_DENOMINATOR (z);
else if (SCM_REALP (z))
return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
else
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 8448b7fd2..2c2fdcf07 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -157,14 +157,6 @@
#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x))
-#define SCM_FRACTION_SET_NUMERATOR(x, v) (SCM_SET_CELL_OBJECT_1 ((x), (v)))
-#define SCM_FRACTION_SET_DENOMINATOR(x, v) (SCM_SET_CELL_OBJECT_2 ((x), (v)))
-
- /* I think the left half word is free in the type, so I'll use bit 17 */
-#define SCM_FRACTION_REDUCED_BIT 0x10000
-#define SCM_FRACTION_REDUCED_SET(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) | SCM_FRACTION_REDUCED_BIT)))
-#define SCM_FRACTION_REDUCED_CLEAR(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) & ~SCM_FRACTION_REDUCED_BIT)))
-#define SCM_FRACTION_REDUCED(x) (0x10000 & SCM_CELL_TYPE (x))
diff --git a/libguile/options.c b/libguile/options.c
index 47cf60a91..ae75e1318 100644
--- a/libguile/options.c
+++ b/libguile/options.c
@@ -95,11 +95,11 @@ static SCM protected_objects = SCM_EOL;
/* Return a list of the current option setting. The format of an
* option setting is described in the above documentation. */
static SCM
-get_option_setting (const scm_t_option options[], unsigned int n)
+get_option_setting (const scm_t_option options[])
{
unsigned int i;
SCM ls = SCM_EOL;
- for (i = 0; i != n; ++i)
+ for (i = 0; options[i].name; ++i)
{
switch (options[i].type)
{
@@ -123,12 +123,12 @@ get_option_setting (const scm_t_option options[], unsigned int n)
/* Return a list of sublists, where each sublist contains option name, value
* and documentation string. */
static SCM
-get_documented_option_setting (const scm_t_option options[], unsigned int n)
+get_documented_option_setting (const scm_t_option options[])
{
SCM ans = SCM_EOL;
unsigned int i;
- for (i = 0; i != n; ++i)
+ for (i = 0; options[i].name; ++i)
{
SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL);
switch (options[i].type)
@@ -149,21 +149,36 @@ get_documented_option_setting (const scm_t_option options[], unsigned int n)
}
+static int
+options_length (scm_t_option options[])
+{
+ unsigned int i = 0;
+ for (; options[i].name != NULL; ++i)
+ ;
+
+ return i;
+}
+
/* Alters options according to the given option setting 'args'. The value of
* args is known to be a list, but it is not known whether the list is a well
* formed option setting, i. e. if for every non-boolean option a value is
* given. For this reason, the function applies all changes to a copy of the
* original setting in memory. Only if 'args' was successfully processed,
- * the new setting will overwrite the old one. */
+ * the new setting will overwrite the old one.
+ *
+ * If DRY_RUN is set, don't change anything. This is useful for trying out an option
+ * before entering a critical section.
+ */
static void
-change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s)
+change_option_setting (SCM args, scm_t_option options[], const char *s,
+ int dry_run)
{
unsigned int i;
SCM locally_protected_args = args;
- SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits));
+ SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits));
scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
- for (i = 0; i != n; ++i)
+ for (i = 0; options[i].name; ++i)
{
if (options[i].type == SCM_OPTION_BOOLEAN)
flags[i] = 0;
@@ -176,7 +191,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c
SCM name = SCM_CAR (args);
int found = 0;
- for (i = 0; i != n && !found; ++i)
+ for (i = 0; options[i].name && !found; ++i)
{
if (scm_is_eq (name, SCM_PACK (options[i].name)))
{
@@ -204,7 +219,10 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c
args = SCM_CDR (args);
}
- for (i = 0; i != n; ++i)
+ if (dry_run)
+ return;
+
+ for (i = 0; options[i].name; ++i)
{
if (options[i].type == SCM_OPTION_SCM)
{
@@ -223,32 +241,39 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c
SCM
-scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s)
+scm_options (SCM args, scm_t_option options[], const char *s)
+{
+ return scm_options_try (args, options, s, 0);
+}
+
+SCM
+scm_options_try (SCM args, scm_t_option options[], const char *s,
+ int dry_run)
{
if (SCM_UNBNDP (args))
- return get_option_setting (options, n);
+ return get_option_setting (options);
else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args))
/* Dirk:FIXME:: This criterion should be improved. IMO it is better to
* demand that args is #t if documentation should be shown than to say
* that every argument except a list will print out documentation. */
- return get_documented_option_setting (options, n);
+ return get_documented_option_setting (options);
else
{
SCM old_setting;
SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
- old_setting = get_option_setting (options, n);
- change_option_setting (args, options, n, s);
+ old_setting = get_option_setting (options);
+ change_option_setting (args, options, s, dry_run);
return old_setting;
}
}
void
-scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n)
+scm_init_opts (SCM (*func) (SCM), scm_t_option options[])
{
unsigned int i;
- for (i = 0; i != n; ++i)
+ for (i = 0; options[i].name; ++i)
{
SCM name = scm_from_locale_symbol (options[i].name);
options[i].name = (char *) SCM_UNPACK (name);
diff --git a/libguile/options.h b/libguile/options.h
index 650081cd2..5b9664958 100644
--- a/libguile/options.h
+++ b/libguile/options.h
@@ -40,8 +40,9 @@ typedef struct scm_t_option
#define SCM_OPTION_SCM 2
-SCM_API SCM scm_options (SCM, scm_t_option [], unsigned int, const char*);
-SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option [], unsigned int n);
+SCM_API SCM scm_options_try (SCM args, scm_t_option options[], const char *s, int dry_run);
+SCM_API SCM scm_options (SCM, scm_t_option [], const char*);
+SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option []);
SCM_API void scm_init_options (void);
#endif /* SCM_OPTIONS_H */
diff --git a/libguile/posix.c b/libguile/posix.c
index 8129c6413..81539baf2 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -119,6 +119,10 @@ extern char ** environ;
# define USE_GNU_LOCALE_API
#endif
+#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
+# include <xlocale.h>
+#endif
+
#if HAVE_CRYPT_H
# include <crypt.h>
#endif
@@ -491,11 +495,25 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
/* Signal values are interned in scm_init_posix(). */
#ifdef HAVE_KILL
if (kill (scm_to_int (pid), scm_to_int (sig)) != 0)
+ SCM_SYSERROR;
#else
+ /* Mingw has raise(), but not kill(). (Other raw DOS environments might
+ be similar.) Use raise() when the requested pid is our own process,
+ otherwise bomb. */
if (scm_to_int (pid) == getpid ())
- if (raise (scm_to_int (sig)) != 0)
+ {
+ if (raise (scm_to_int (sig)) != 0)
+ {
+ err:
+ SCM_SYSERROR;
+ }
+ else
+ {
+ errno = ENOSYS;
+ goto err;
+ }
+ }
#endif
- SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1316,9 +1334,6 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
{
int rv;
char *c_str = scm_to_locale_string (str);
-#ifdef __MINGW32__
- size_t len = strlen (c_str);
-#endif
if (strchr (c_str, '=') == NULL)
{
@@ -1333,6 +1348,7 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
/* On e.g. Win32 hosts putenv() called with 'name=' removes the
environment variable 'name'. */
int e;
+ size_t len = strlen (c_str);
char *ptr = scm_malloc (len + 2);
strcpy (ptr, c_str);
strcpy (ptr+len, "=");
@@ -1352,26 +1368,29 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
by getenv. It's not enough just to modify the string we set,
because MINGW putenv copies it. */
- if (c_str[len-1] == '=')
- {
- char *ptr = scm_malloc (len+2);
- strcpy (ptr, c_str);
- strcpy (ptr+len, " ");
- rv = putenv (ptr);
- if (rv < 0)
- {
- int eno = errno;
- free (c_str);
- errno = eno;
- SCM_SYSERROR;
- }
- /* truncate to just the name */
- c_str[len-1] = '\0';
- ptr = getenv (c_str);
- if (ptr)
- ptr[0] = '\0';
- return SCM_UNSPECIFIED;
- }
+ {
+ size_t len = strlen (c_str);
+ if (c_str[len-1] == '=')
+ {
+ char *ptr = scm_malloc (len+2);
+ strcpy (ptr, c_str);
+ strcpy (ptr+len, " ");
+ rv = putenv (ptr);
+ if (rv < 0)
+ {
+ int eno = errno;
+ free (c_str);
+ errno = eno;
+ SCM_SYSERROR;
+ }
+ /* truncate to just the name */
+ c_str[len-1] = '\0';
+ ptr = getenv (c_str);
+ if (ptr)
+ ptr[0] = '\0';
+ return SCM_UNSPECIFIED;
+ }
+ }
#endif /* __MINGW32__ */
/* Leave c_str in the environment. */
@@ -1384,12 +1403,11 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
}
#undef FUNC_NAME
-#ifndef USE_GNU_LOCALE_API
/* This mutex is used to serialize invocations of `setlocale ()' on non-GNU
- systems (i.e., systems where a reentrant locale API is not available).
- See `i18n.c' for details. */
-scm_i_pthread_mutex_t scm_i_locale_mutex;
-#endif
+ systems (i.e., systems where a reentrant locale API is not available). It
+ is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for
+ details. */
+scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef HAVE_SETLOCALE
@@ -1406,6 +1424,7 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
"the locale will be set using environment variables.")
#define FUNC_NAME s_scm_setlocale
{
+ int c_category;
char *clocale;
char *rv;
@@ -1421,13 +1440,11 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
scm_dynwind_free (clocale);
}
-#ifndef USE_GNU_LOCALE_API
+ c_category = scm_i_to_lc_category (category, 1);
+
scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
-#endif
- rv = setlocale (scm_i_to_lc_category (category, 1), clocale);
-#ifndef USE_GNU_LOCALE_API
+ rv = setlocale (c_category, clocale);
scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
-#endif
if (rv == NULL)
{
@@ -1565,7 +1582,7 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
#define FUNC_NAME s_scm_crypt
{
SCM ret;
- char *c_key, *c_salt;
+ char *c_key, *c_salt, *c_ret;
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
@@ -1575,8 +1592,14 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
c_salt = scm_to_locale_string (salt);
scm_dynwind_free (c_salt);
- ret = scm_from_locale_string (crypt (c_key, c_salt));
+ /* The Linux crypt(3) man page says crypt will return NULL and set errno
+ on error. (Eg. ENOSYS if legal restrictions mean it cannot be
+ implemented). */
+ c_ret = crypt (c_key, c_salt);
+ if (c_ret == NULL)
+ SCM_SYSERROR;
+ ret = scm_from_locale_string (c_ret);
scm_dynwind_end ();
return ret;
}
@@ -1965,10 +1988,6 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
void
scm_init_posix ()
{
-#ifndef USE_GNU_LOCALE_API
- scm_i_pthread_mutex_init (&scm_i_locale_mutex, NULL);
-#endif
-
scm_add_feature ("posix");
#ifdef HAVE_GETEUID
scm_add_feature ("EIDs");
diff --git a/libguile/print.c b/libguile/print.c
index 32507d2ab..3064fa1bd 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -43,6 +43,9 @@
#include "libguile/validate.h"
#include "libguile/print.h"
+
+#include "libguile/private-options.h"
+
/* {Names of immediate symbols}
@@ -83,7 +86,9 @@ scm_t_option scm_print_opts[] = {
"How to print symbols that have a colon as their first or last character. "
"The value '#f' does not quote the colons; '#t' quotes them; "
"'reader' quotes them when the reader option 'keywords' is not '#f'."
- }
+ },
+ { 0 },
+
};
SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
@@ -96,7 +101,6 @@ SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
{
SCM ans = scm_options (setting,
scm_print_opts,
- SCM_N_PRINT_OPTIONS,
FUNC_NAME);
return ans;
}
@@ -940,12 +944,14 @@ scm_write (SCM obj, SCM port)
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
scm_prin1 (obj, port, 1);
+#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
scm_close_port (port);
# endif
#endif
+#endif
return SCM_UNSPECIFIED;
}
@@ -961,12 +967,14 @@ scm_display (SCM obj, SCM port)
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
scm_prin1 (obj, port, 0);
+#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
scm_close_port (port);
# endif
#endif
+#endif
return SCM_UNSPECIFIED;
}
@@ -1098,12 +1106,14 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
SCM_VALIDATE_OPORT_VALUE (2, port);
scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
+#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
scm_close_port (port);
# endif
#endif
+#endif
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1173,7 +1183,7 @@ scm_init_print ()
{
SCM vtable, layout, type;
- scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
+ scm_init_opts (scm_print_options, scm_print_opts);
scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"),
scm_from_locale_string ("{"),
diff --git a/libguile/print.h b/libguile/print.h
index 7e59ba8b3..740aa281f 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -26,15 +26,6 @@
#include "libguile/options.h"
-SCM_API scm_t_option scm_print_opts[];
-
-#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val))
-#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
-#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[2].val))
-#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[3].val))
-#define SCM_PRINT_KEYWORD_STYLE_I 4
-#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[4].val))
-#define SCM_N_PRINT_OPTIONS 5
/* State information passed around during printing.
*/
diff --git a/libguile/private-gc.h b/libguile/private-gc.h
index c27196355..fe9b35505 100644
--- a/libguile/private-gc.h
+++ b/libguile/private-gc.h
@@ -1,7 +1,22 @@
/*
- (c) FSF 2002.
-*/
-
+ * private-gc.h - private declarations for garbage collection.
+ *
+ * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef PRIVATE_GC
#define PRIVATE_GC
diff --git a/libguile/private-options.h b/libguile/private-options.h
new file mode 100644
index 000000000..eeaf0c17b
--- /dev/null
+++ b/libguile/private-options.h
@@ -0,0 +1,103 @@
+/*
+ * private-options.h - private declarations for option handling
+ *
+ * We put this in a private header, since layout of data structures
+ * is an implementation detail that we want to hide.
+ *
+ * Copyright (C) 2007 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifndef PRIVATE_OPTIONS
+#define PRIVATE_OPTIONS
+
+/*
+ evaluator
+ */
+SCM_API scm_t_option scm_eval_opts[];
+
+SCM_API long scm_eval_stack;
+
+SCM_API scm_t_option scm_evaluator_trap_table[];
+
+SCM_API SCM scm_eval_options_interface (SCM setting);
+
+#define SCM_EVAL_STACK scm_eval_opts[0].val
+
+#define SCM_TRAPS_P scm_evaluator_trap_table[0].val
+#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val
+#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val
+#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val
+#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val))
+#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val))
+#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val))
+#define SCM_MEMOIZE_P scm_evaluator_trap_table[7].val
+#define SCM_MEMOIZE_HDLR (SCM_PACK (scm_evaluator_trap_table[8].val))
+
+/*
+ debugging.
+ */
+SCM_API scm_t_option scm_debug_opts[];
+
+#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
+#define SCM_TRACE_P scm_debug_opts[2].val
+#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
+#define SCM_BACKWARDS_P scm_debug_opts[4].val
+#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val
+#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val
+#define SCM_N_FRAMES scm_debug_opts[7].val
+#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val
+#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val
+#define SCM_BACKTRACE_P scm_debug_opts[10].val
+#define SCM_DEVAL_P scm_debug_opts[11].val
+#define SCM_STACK_LIMIT scm_debug_opts[12].val
+#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val
+#define SCM_WARN_DEPRECATED scm_debug_opts[14].val
+#define SCM_N_DEBUG_OPTIONS 15
+
+
+/*
+ printing
+*/
+SCM_API scm_t_option scm_print_opts[];
+
+#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val))
+#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
+#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[2].val))
+#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[3].val))
+#define SCM_PRINT_KEYWORD_STYLE_I 4
+#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[4].val))
+#define SCM_N_PRINT_OPTIONS 5
+
+
+/*
+ read
+ */
+SCM_API scm_t_option scm_read_opts[];
+
+#define SCM_COPY_SOURCE_P scm_read_opts[0].val
+#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
+#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
+#define SCM_KEYWORD_STYLE scm_read_opts[3].val
+#if SCM_ENABLE_ELISP
+#define SCM_ELISP_VECTORS_P scm_read_opts[4].val
+#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val
+#define SCM_N_READ_OPTIONS 6
+#else
+#define SCM_N_READ_OPTIONS 4
+#endif
+
+#endif /* PRIVATE_OPTIONS */
diff --git a/libguile/read.c b/libguile/read.c
index d75839589..de2e87bed 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -38,6 +38,8 @@
#include "libguile/srfi-4.h"
#include "libguile/read.h"
+#include "libguile/private-options.h"
+
@@ -52,14 +54,14 @@ scm_t_option scm_read_opts[] = {
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0,
"Convert symbols to lower case."},
{ SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
- "Style of keyword recognition: #f or 'prefix."}
+ "Style of keyword recognition: #f or 'prefix."},
#if SCM_ENABLE_ELISP
- ,
{ SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
"Support Elisp vector syntax, namely `[...]'."},
{ SCM_OPTION_BOOLEAN, "elisp-strings", 0,
- "Support `\\(' and `\\)' in strings."}
+ "Support `\\(' and `\\)' in strings."},
#endif
+ { 0, },
};
/*
@@ -112,7 +114,6 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
{
SCM ans = scm_options (setting,
scm_read_opts,
- SCM_N_READ_OPTIONS,
FUNC_NAME);
if (SCM_COPY_SOURCE_P)
SCM_RECORD_POSITIONS_P = 1;
@@ -898,7 +899,9 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
"starting with the character sequence @code{#} and @var{chr}.\n"
"@var{proc} will be called with two arguments: the character\n"
"@var{chr} and the port to read further data from. The object\n"
- "returned will be the return value of @code{read}.")
+ "returned will be the return value of @code{read}. \n"
+ "Passing @code{#f} for @var{proc} will remove a previous setting. \n"
+ )
#define FUNC_NAME s_scm_read_hash_extend
{
SCM this;
@@ -977,7 +980,7 @@ scm_init_read ()
scm_read_hash_procedures =
SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));
- scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
+ scm_init_opts (scm_read_options, scm_read_opts);
#include "libguile/read.x"
}
diff --git a/libguile/read.h b/libguile/read.h
index 4bfa59eb0..9ff362603 100644
--- a/libguile/read.h
+++ b/libguile/read.h
@@ -45,19 +45,7 @@
#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t'
-SCM_API scm_t_option scm_read_opts[];
-
-#define SCM_COPY_SOURCE_P scm_read_opts[0].val
-#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
-#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
-#define SCM_KEYWORD_STYLE scm_read_opts[3].val
-#if SCM_ENABLE_ELISP
-#define SCM_ELISP_VECTORS_P scm_read_opts[4].val
-#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val
-#define SCM_N_READ_OPTIONS 6
-#else
-#define SCM_N_READ_OPTIONS 4
-#endif
+
diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c
index 9332f2661..f8677a1a3 100644
--- a/libguile/regex-posix.c
+++ b/libguile/regex-posix.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -218,6 +218,17 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
"@end table")
#define FUNC_NAME s_scm_regexp_exec
{
+ /* We used to have an SCM_DEFER_INTS, and then later an
+ SCM_CRITICAL_SECTION_START, around the regexec() call. Can't quite
+ remember what defer ints was for, but a critical section would only be
+ wanted now if we think regexec() is not thread-safe. The posix spec
+
+ http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html
+
+ reads like regexec is meant to be both thread safe and reentrant
+ (mentioning simultaneous use in threads, and in signal handlers). So
+ for now believe no protection needed. */
+
int status, nmatches, offset;
regmatch_t *matches;
char *c_str;
@@ -245,7 +256,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
whole regexp, so add 1 to nmatches. */
nmatches = SCM_RGX(rx)->re_nsub + 1;
- SCM_CRITICAL_SECTION_START;
matches = scm_malloc (sizeof (regmatch_t) * nmatches);
c_str = scm_to_locale_string (substr);
status = regexec (SCM_RGX (rx), c_str, nmatches, matches,
@@ -269,7 +279,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
scm_from_long (matches[i].rm_eo + offset)));
}
free (matches);
- SCM_CRITICAL_SECTION_END;
if (status != 0 && status != REG_NOMATCH)
scm_error_scm (scm_regexp_error_key,
@@ -287,14 +296,14 @@ scm_init_regex_posix ()
scm_set_smob_free (scm_tc16_regex, regex_free);
/* Compilation flags. */
- scm_c_define ("regexp/basic", scm_from_long (REG_BASIC));
- scm_c_define ("regexp/extended", scm_from_long (REG_EXTENDED));
- scm_c_define ("regexp/icase", scm_from_long (REG_ICASE));
- scm_c_define ("regexp/newline", scm_from_long (REG_NEWLINE));
+ scm_c_define ("regexp/basic", scm_from_int (REG_BASIC));
+ scm_c_define ("regexp/extended", scm_from_int (REG_EXTENDED));
+ scm_c_define ("regexp/icase", scm_from_int (REG_ICASE));
+ scm_c_define ("regexp/newline", scm_from_int (REG_NEWLINE));
/* Execution flags. */
- scm_c_define ("regexp/notbol", scm_from_long (REG_NOTBOL));
- scm_c_define ("regexp/noteol", scm_from_long (REG_NOTEOL));
+ scm_c_define ("regexp/notbol", scm_from_int (REG_NOTBOL));
+ scm_c_define ("regexp/noteol", scm_from_int (REG_NOTEOL));
#include "libguile/regex-posix.x"
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index 3452f911c..9b1c96d42 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -22,6 +22,7 @@
# include <config.h>
#endif
+#include <fcntl.h> /* for mingw */
#include <signal.h>
#include <stdio.h>
#include <errno.h>
@@ -36,6 +37,14 @@
#include "libguile/validate.h"
#include "libguile/scmsigs.h"
+#ifdef HAVE_IO_H
+#include <io.h> /* for mingw _pipe() */
+#endif
+
+#ifdef HAVE_PROCESS_H
+#include <process.h> /* for mingw */
+#endif
+
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -50,7 +59,7 @@
/* This weird comma expression is because Sleep is void under Windows. */
#define sleep(sec) (Sleep ((sec) * 1000), 0)
#define usleep(usec) (Sleep ((usec) / 1000), 0)
-#define kill(pid, sig) raise (sig)
+#define pipe(fd) _pipe (fd, 256, O_BINARY)
#endif
@@ -106,6 +115,12 @@ close_1 (SCM proc, SCM arg)
}
#if SCM_USE_PTHREAD_THREADS
+/* On mingw there's no notion of inter-process signals, only a raise()
+ within the process itself which apparently invokes the registered handler
+ immediately. Not sure how well the following code will cope in this
+ case. It builds but it may not offer quite the same scheme-level
+ semantics as on a proper system. If you're relying on much in the way of
+ signal handling on mingw you probably lose anyway. */
static int signal_pipe[2];
@@ -149,12 +164,13 @@ read_without_guile (int fd, char *buf, size_t n)
static SCM
signal_delivery_thread (void *data)
{
- sigset_t all_sigs;
int n, sig;
char sigbyte;
-
+#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */
+ sigset_t all_sigs;
sigfillset (&all_sigs);
scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
+#endif
while (1)
{
@@ -616,7 +632,7 @@ SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
"@var{sig} is as described for the kill procedure.")
#define FUNC_NAME s_scm_raise
{
- if (kill (getpid (), scm_to_int (sig)) != 0)
+ if (raise (scm_to_int (sig)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 8b9348e85..e3691d4fb 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -38,7 +38,7 @@
/* {Source Properties}
*
* Properties of source list expressions.
- * Five of these have special meaning and optimized storage:
+ * Five of these have special meaning:
*
* filename string The name of the source file.
* copy list A copy of the list expression.
@@ -56,8 +56,46 @@ SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
+
+
+/*
+ * Source properties are stored as double cells with the
+ * following layout:
+
+ * car = tag
+ * cbr = pos
+ * ccr = copy
+ * cdr = plist
+ */
+
+#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
+#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
+#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
+#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
+#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
+#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
+#define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p))
+#define SETSRCPROPBRK(p) \
+ (SCM_SET_SMOB_FLAGS ((p), \
+ SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
+#define CLEARSRCPROPBRK(p) \
+ (SCM_SET_SMOB_FLAGS ((p), \
+ SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
+#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
+#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
+#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
+#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
+
+
+
scm_t_bits scm_tc16_srcprops;
+static SCM
+srcprops_mark (SCM obj)
+{
+ scm_gc_mark (SRCPROPCOPY (obj));
+ return SRCPROPPLIST (obj);
+}
static int
srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
@@ -80,19 +118,45 @@ scm_c_source_property_breakpoint_p (SCM form)
}
+/*
+ * We remember the last file name settings, so we can share that plist
+ * entry. This works because scm_set_source_property_x does not use
+ * assoc-set! for modifying the plist.
+ *
+ * This variable contains a protected cons, whose cdr is the cached
+ * plist
+ */
+static SCM scm_last_plist_filename;
+
SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
{
- register scm_t_srcprops *ptr;
-
- ptr = scm_gc_malloc (sizeof (*ptr), "srcprop");
-
- ptr->pos = SRCPROPMAKPOS (line, col);
- ptr->fname = filename;
- ptr->copy = copy;
- ptr->plist = plist;
+ if (!SCM_UNBNDP (filename))
+ {
+ SCM old_plist = plist;
- SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
+ /*
+ have to extract the acons, and operate on that, for
+ thread safety.
+ */
+ SCM last_acons = SCM_CDR (scm_last_plist_filename);
+ if (old_plist == SCM_EOL
+ && SCM_CDAR (last_acons) == filename)
+ {
+ plist = last_acons;
+ }
+ else
+ {
+ plist = scm_acons (scm_sym_filename, filename, plist);
+ if (old_plist == SCM_EOL)
+ SCM_SETCDR (scm_last_plist_filename, plist);
+ }
+ }
+
+ SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
+ SRCPROPMAKPOS (line, col),
+ copy,
+ plist);
}
@@ -102,8 +166,6 @@ scm_srcprops_to_plist (SCM obj)
SCM plist = SRCPROPPLIST (obj);
if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
- if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
- plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist);
plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist);
plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist);
plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist);
@@ -168,7 +230,6 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p));
else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p));
else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p));
- else if (scm_is_eq (scm_sym_filename, key)) p = SRCPROPFNAME (p);
else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p);
else
{
@@ -239,13 +300,6 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
scm_make_srcprops (0, scm_to_int (datum),
SCM_UNDEFINED, SCM_UNDEFINED, p));
}
- else if (scm_is_eq (scm_sym_filename, key))
- {
- if (SRCPROPSP (p))
- SRCPROPFNAME (p) = datum;
- else
- SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
- }
else if (scm_is_eq (scm_sym_copy, key))
{
if (SRCPROPSP (p))
@@ -269,19 +323,19 @@ void
scm_init_srcprop ()
{
scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
+ scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark);
scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
scm_c_define ("source-whash", scm_source_whash);
+ scm_last_plist_filename
+ = scm_permanent_object (scm_cons (SCM_EOL,
+ scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
+
#include "libguile/srcprop.x"
}
-void
-scm_finish_srcprop ()
-{
- /* Nothing to do. */
-}
/*
Local Variables:
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 0806a299e..87e5fde0f 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -49,40 +49,10 @@ do { \
/* {Source properties}
*/
-
-SCM_API scm_t_bits scm_tc16_srcprops;
-
-typedef struct scm_t_srcprops
-{
- unsigned long pos;
- SCM fname;
- SCM copy;
- SCM plist;
-} scm_t_srcprops;
-
-
+#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
-#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
-#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
-#define SRCPROPPOS(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->pos
-#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
-#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
-#define SRCPROPFNAME(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->fname
-#define SRCPROPCOPY(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->copy
-#define SRCPROPPLIST(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->plist
-#define SETSRCPROPBRK(p) \
- (SCM_SET_SMOB_FLAGS ((p), \
- SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
-#define CLEARSRCPROPBRK(p) \
- (SCM_SET_SMOB_FLAGS ((p), \
- SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
-#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
-#define SETSRCPROPPOS(p, l, c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c))
-#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
-#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
-
-#define PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
+SCM_API scm_t_bits scm_tc16_srcprops;
SCM_API SCM scm_sym_filename;
SCM_API SCM scm_sym_copy;
diff --git a/libguile/stacks.c b/libguile/stacks.c
index de85522ca..922c52231 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -32,6 +32,8 @@
#include "libguile/validate.h"
#include "libguile/stacks.h"
+#include "libguile/private-options.h"
+
/* {Frames and stacks}
diff --git a/libguile/struct.c b/libguile/struct.c
index 181b3d32c..e96a4912a 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -540,10 +540,15 @@ scm_i_struct_equalp (SCM s1, SCM s2)
field1 = scm_struct_ref (s1, s_field_num);
field2 = scm_struct_ref (s2, s_field_num);
- if (scm_is_false (scm_equal_p (field1, field2)))
- return SCM_BOOL_F;
+ /* Self-referencing fields (type `s') must be skipped to avoid infinite
+ recursion. */
+ if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
+ if (scm_is_false (scm_equal_p (field1, field2)))
+ return SCM_BOOL_F;
}
+ /* FIXME: Tail elements should be tested for equality. */
+
return SCM_BOOL_T;
}
#undef FUNC_NAME
diff --git a/libguile/symbols.c b/libguile/symbols.c
index e702fd3b4..ff75bef7d 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -40,6 +40,9 @@
#include "libguile/validate.h"
#include "libguile/symbols.h"
+#include "libguile/private-options.h"
+
+
#ifdef HAVE_STRING_H
#include <string.h>
#endif
diff --git a/libguile/threads.c b/libguile/threads.c
index d15046bd2..c0a6cf110 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -131,9 +131,32 @@ dequeue (SCM q)
static int
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
+ /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
+ struct. A cast like "(unsigned long) t->pthread" is a syntax error in
+ the struct case, hence we go via a union, and extract according to the
+ size of pthread_t. */
+ union {
+ scm_i_pthread_t p;
+ unsigned short us;
+ unsigned int ui;
+ unsigned long ul;
+ scm_t_uintmax um;
+ } u;
scm_i_thread *t = SCM_I_THREAD_DATA (exp);
+ scm_i_pthread_t p = t->pthread;
+ scm_t_uintmax id;
+ u.p = p;
+ if (sizeof (p) == sizeof (unsigned short))
+ id = u.us;
+ else if (sizeof (p) == sizeof (unsigned int))
+ id = u.ui;
+ else if (sizeof (p) == sizeof (unsigned long))
+ id = u.ul;
+ else
+ id = u.um;
+
scm_puts ("#<thread ", port);
- scm_uintprint ((size_t)t->pthread, 10, port);
+ scm_uintprint (id, 10, port);
scm_puts (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
scm_puts (")>", port);
@@ -563,9 +586,11 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
}
#if SCM_USE_PTHREAD_THREADS
-/* pthread_getattr_np not available on MacOS X and Solaris 10. */
-#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
+#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
+/* This method for GNU/Linux and perhaps some other systems.
+ It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
+ available on them. */
#define HAVE_GET_THREAD_STACK_BASE
static SCM_STACKITEM *
@@ -598,7 +623,30 @@ get_thread_stack_base ()
}
}
-#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */
+#elif HAVE_PTHREAD_GET_STACKADDR_NP
+/* This method for MacOS X.
+ It'd be nice if there was some documentation on pthread_get_stackaddr_np,
+ but as of 2006 there's nothing obvious at apple.com. */
+#define HAVE_GET_THREAD_STACK_BASE
+static SCM_STACKITEM *
+get_thread_stack_base ()
+{
+ return pthread_get_stackaddr_np (pthread_self ());
+}
+
+#elif defined (__MINGW32__)
+/* This method for mingw. In mingw the basic scm_get_stack_base can be used
+ in any thread. We don't like hard-coding the name of a system, but there
+ doesn't seem to be a cleaner way of knowing scm_get_stack_base can
+ work. */
+#define HAVE_GET_THREAD_STACK_BASE
+static SCM_STACKITEM *
+get_thread_stack_base ()
+{
+ return scm_get_stack_base ();
+}
+
+#endif /* pthread methods of get_thread_stack_base */
#else /* !SCM_USE_PTHREAD_THREADS */
diff --git a/libguile/throw.c b/libguile/throw.c
index 115bb0c03..02503c36a 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -37,6 +37,10 @@
#include "libguile/validate.h"
#include "libguile/throw.h"
#include "libguile/init.h"
+#include "libguile/strings.h"
+
+#include "libguile/private-options.h"
+
/* the jump buffer data structure */
@@ -695,7 +699,31 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
if (scm_i_critical_section_level)
{
+ SCM s = args;
+ int i = 0;
+
+ /*
+ We have much better routines for displaying Scheme, but we're
+ already inside a pernicious error, and it's unlikely that they
+ are available to us. We try to print something useful anyway,
+ so users don't need a debugger to find out what went wrong.
+ */
fprintf (stderr, "throw from within critical section.\n");
+ if (scm_is_symbol (key))
+ fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key));
+
+
+ for (; scm_is_pair (s); s = scm_cdr (s), i++)
+ {
+ char const *str = NULL;
+ if (scm_is_string (scm_car (s)))
+ str = scm_i_string_chars (scm_car (s));
+ else if (scm_is_symbol (scm_car (s)))
+ str = scm_i_symbol_chars (scm_car (s));
+
+ if (str != NULL)
+ fprintf (stderr, "argument %d: %s\n", i, str);
+ }
abort ();
}
diff --git a/libguile/version.h.in b/libguile/version.h.in
index 691898cd5..1d8f27750 100644
--- a/libguile/version.h.in
+++ b/libguile/version.h.in
@@ -30,12 +30,12 @@
#define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@
#define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@
-extern SCM scm_major_version (void);
-extern SCM scm_minor_version (void);
-extern SCM scm_micro_version (void);
-extern SCM scm_effective_version (void);
-extern SCM scm_version (void);
-extern void scm_init_version (void);
+SCM_API SCM scm_major_version (void);
+SCM_API SCM scm_minor_version (void);
+SCM_API SCM scm_micro_version (void);
+SCM_API SCM scm_effective_version (void);
+SCM_API SCM scm_version (void);
+SCM_API void scm_init_version (void);
#endif /* SCM_VERSION_H */