mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

Avoid accessing symbol internals in call_dsubr_1 and DEVAL

Browse source 
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
This commit is contained in:
Michael Gran 2009-08-20 20:30:12 -07:00
parent 7f5946427e
commit 0193377d24
5 changed files with 25 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

7
libguile/__scm.h
View file

@ -556,6 +556,13 @@ SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
return (SCM_UNPACK (gf) \ return (SCM_UNPACK (gf) \
? scm_call_generic_1 ((gf), (a1)) \ ? scm_call_generic_1 ((gf), (a1)) \
: (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED)) : (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) \ #define SCM_GASSERT1(cond, gf, a1, pos, subr) \
if (SCM_UNLIKELY (!(cond))) \ if (SCM_UNLIKELY (!(cond))) \
SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr)) SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))

13
libguile/error.c
View file

@ -232,6 +232,19 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
scm_list_1 (bad_value)); scm_list_1 (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 void
scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage) scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
{ {

2
libguile/error.h
View file

@ -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_error_num_args_subr (const char* subr) SCM_NORETURN;
SCM_API void scm_wrong_type_arg (const char *subr, int pos, SCM_API void scm_wrong_type_arg (const char *subr, int pos,
SCM bad_value) SCM_NORETURN; 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_API void scm_wrong_type_arg_msg (const char *subr, int pos,
SCM bad_value, const char *sz) SCM_NORETURN; SCM bad_value, const char *sz) SCM_NORETURN;
SCM_API void scm_memory_error (const char *subr) SCM_NORETURN; SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;

3
libguile/eval.c
View file

@ -3381,8 +3381,7 @@ call_dsubr_1 (SCM proc, SCM 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_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
} }
static SCM static SCM

7
libguile/eval.i.c
View file

@ -1238,9 +1238,7 @@ dispatch:
{ {
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_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
SCM_ARG1,
scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
case scm_tc7_cxr: case scm_tc7_cxr:
RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
@ -1781,8 +1779,7 @@ tail:
{ {
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_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
case scm_tc7_cxr: case scm_tc7_cxr:
if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args))) if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
scm_wrong_num_args (proc); scm_wrong_num_args (proc);