summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichael Gran <spk121@yahoo.com>2009-08-20 20:30:12 -0700
committerMichael Gran <spk121@yahoo.com>2009-08-20 21:39:56 -0700
commit0193377d24db3ec57ea9be488069a4b86878e6e6 (patch)
treeb61bdf868d4e3cedd05ec45827d011a826dfa1cc
parent7f5946427e457b5588b1a5103dc4652bd9a99392 (diff)
downloadguile-0193377d24db3ec57ea9be488069a4b86878e6e6.tar.gz
Avoid accessing symbol internals in call_dsubr_1 and DEVAL
The symbol's characters are only accessed in case they are needed for an error message. This can be avoided by passing the symbol all the way to a error message function. * libguile/__scm.h (SCM_WTA_DISPATCH_1_SUBR): new macro * libguile/error.c (scm_i_wrong_type_arg_symbol): new error function * libguile/error.h: declaration of scm_i_wrong_type_arg_symbol * libguile/eval.c (call_dsubr_1): use new macro SCM_WTA_DISPATCH_1_SUBR to avoid having to unpack the symbol's chars * libguile/eval.i.c: use new macro SCM_WTA_DISPATCH_1_SUBR
-rw-r--r--libguile/__scm.h7
-rw-r--r--libguile/error.c13
-rw-r--r--libguile/error.h2
-rw-r--r--libguile/eval.c3
-rw-r--r--libguile/eval.i.c7
5 files changed, 25 insertions, 7 deletions
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 29b371d16..b92eeae83 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -556,6 +556,13 @@ SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
return (SCM_UNPACK (gf) \
? scm_call_generic_1 ((gf), (a1)) \
: (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED))
+
+/* This form is for dispatching a subroutine. */
+#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \
+ return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \
+ ? scm_call_generic_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \
+ : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
+
#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
if (SCM_UNLIKELY (!(cond))) \
SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))
diff --git a/libguile/error.c b/libguile/error.c
index eb513a74a..bcbcd9cd1 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -233,6 +233,19 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
}
void
+scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value)
+{
+ scm_error_scm (scm_arg_type_key,
+ scm_symbol_to_string (symbol),
+ (pos == 0) ? scm_from_locale_string ("Wrong type: ~S")
+ : scm_from_locale_string ("Wrong type argument in position ~A: ~S"),
+ (pos == 0) ? scm_list_1 (bad_value)
+ : scm_list_2 (scm_from_int (pos), bad_value),
+ scm_list_1 (bad_value));
+ scm_remember_upto_here_2 (symbol, bad_value);
+}
+
+void
scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
{
SCM msg = scm_from_locale_string (szMessage);
diff --git a/libguile/error.h b/libguile/error.h
index c777a7f44..8cc68b752 100644
--- a/libguile/error.h
+++ b/libguile/error.h
@@ -53,6 +53,8 @@ SCM_API void scm_wrong_num_args (SCM proc) SCM_NORETURN;
SCM_API void scm_error_num_args_subr (const char* subr) SCM_NORETURN;
SCM_API void scm_wrong_type_arg (const char *subr, int pos,
SCM bad_value) SCM_NORETURN;
+SCM_INTERNAL void scm_i_wrong_type_arg_symbol (SCM symbol, int pos,
+ SCM bad_value) SCM_NORETURN;
SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos,
SCM bad_value, const char *sz) SCM_NORETURN;
SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;
diff --git a/libguile/eval.c b/libguile/eval.c
index 1563b5125..eeafb0b9d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -3381,8 +3381,7 @@ call_dsubr_1 (SCM proc, SCM 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_SUBR_NAME (proc)));
+ SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
}
static SCM
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 461349a2b..25abf6cb9 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -1238,9 +1238,7 @@ dispatch:
{
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_SUBR_NAME (proc)));
+ SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
case scm_tc7_cxr:
RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
case scm_tc7_rpsubr:
@@ -1781,8 +1779,7 @@ tail:
{
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_SUBR_NAME (proc)));
+ SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
case scm_tc7_cxr:
if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
scm_wrong_num_args (proc);