mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
move subr implementation details to gsubr.[ch]
* libguile/procs.h: Move subr macros to gsubr.h. * libguile/procs.c (scm_c_make_subr, scm_c_make_subr_with_generic) (scm_c_define_subr, scm_c_define_subr_with_generic): Remove these, because they deal in subr types, and now there is only one subr type. The body of this code is now in gsubr.c. * libguile/deprecated.h (scm_subr_p): Remove from procs.[ch] and define as a deprecated macro. Only used internally, but who knows who's out there. * libguile/goops.c (scm_generic_capability_p) (scm_enable_primitive_generic_x, scm_set_primitive_generic_x) (scm_primitive_generic_generic): Use the new SCM_PRIMITIVE_GENERIC_P macro instead of calling scm_subr_p. * libguile/gsubr.h (SCM_PRIMITIVE_P, SCM_PRIMITIVE_GENERIC_P): New macros, to replace scm_subr_p and hacky checking for generic capability. (SCM_SUBR_META_INFO, SCM_SUBR_NAME, SCM_SUBRF, SCM_SUBR_PROPS) (SCM_SUBR_GENERIC, SCM_SET_SUBR_GENERIC, SCM_SET_SUBR_GENERIC_LOC) (SCM_SUBR_ARITY_TO_TYPE): Moved here from procs.h. * libguile/gsubr.c (create_gsubr): Inline the scm_c_make_subr definition here, and work for generics too. Removed a scm_remember_upto_here_1 that was added earlier in the year when meta_info was not being traced by the GC. Adapt callers.
This commit is contained in:
Andy Wingo
parent
e809758a7e
commit
9fdf9fd3ea
6 changed files with 53 additions and 133 deletions
|
|
@ -598,6 +598,11 @@ SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
|
|||
|
||||
|
||||
|
||||
/* Deprecated 2010-01-05, use SCM_PRIMITIVE_P instead */
|
||||
#define scm_subr_p(x) (SCM_PRIMITIVE_P (x))
|
||||
|
||||
|
||||
|
||||
void scm_i_init_deprecated (void);
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@
|
|||
#include "libguile/dynl.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/gsubr.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/keywords.h"
|
||||
#include "libguile/macros.h"
|
||||
|
|
@ -1693,9 +1694,7 @@ SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
|
|||
{
|
||||
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
|
||||
proc, SCM_ARG1, FUNC_NAME);
|
||||
return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
|
||||
? SCM_BOOL_T
|
||||
: SCM_BOOL_F);
|
||||
return (SCM_PRIMITIVE_GENERIC_P (proc) ? SCM_BOOL_T : SCM_BOOL_F);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -1708,8 +1707,7 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1
|
|||
while (!scm_is_null (subrs))
|
||||
{
|
||||
SCM subr = SCM_CAR (subrs);
|
||||
SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
|
||||
subr, SCM_ARGn, FUNC_NAME);
|
||||
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
|
||||
*SCM_SUBR_GENERIC (subr)
|
||||
= scm_make (scm_list_3 (scm_class_generic,
|
||||
k_name,
|
||||
|
|
@ -1725,8 +1723,7 @@ SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
|
|||
"")
|
||||
#define FUNC_NAME s_scm_set_primitive_generic_x
|
||||
{
|
||||
SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
|
||||
subr, SCM_ARG1, FUNC_NAME);
|
||||
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
|
||||
SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
|
||||
*SCM_SUBR_GENERIC (subr) = generic;
|
||||
return SCM_UNSPECIFIED;
|
||||
|
|
@ -1738,7 +1735,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
|
|||
"")
|
||||
#define FUNC_NAME s_scm_primitive_generic_generic
|
||||
{
|
||||
if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
|
||||
if (SCM_PRIMITIVE_GENERIC_P (subr))
|
||||
{
|
||||
if (!*SCM_SUBR_GENERIC (subr))
|
||||
scm_enable_primitive_generic_x (scm_list_1 (subr));
|
||||
|
|
|
|||
|
|
@ -48,9 +48,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
|
|||
static SCM
|
||||
create_gsubr (int define, const char *name,
|
||||
unsigned int req, unsigned int opt, unsigned int rst,
|
||||
SCM (*fcn) ())
|
||||
SCM (*fcn) (), SCM *generic_loc)
|
||||
{
|
||||
SCM subr;
|
||||
SCM sname;
|
||||
SCM *meta_info;
|
||||
unsigned type;
|
||||
|
||||
type = SCM_GSUBR_MAKTYPE (req, opt, rst);
|
||||
|
|
@ -59,11 +61,18 @@ create_gsubr (int define, const char *name,
|
|||
|| SCM_GSUBR_REST (type) != rst)
|
||||
scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
|
||||
|
||||
subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
|
||||
fcn);
|
||||
meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
|
||||
sname = scm_from_locale_symbol (name);
|
||||
meta_info[0] = sname;
|
||||
meta_info[1] = SCM_EOL; /* properties */
|
||||
|
||||
subr = scm_double_cell ((scm_t_bits) scm_tc7_gsubr | (type << 8U),
|
||||
(scm_t_bits) fcn,
|
||||
(scm_t_bits) generic_loc,
|
||||
(scm_t_bits) meta_info);
|
||||
|
||||
if (define)
|
||||
scm_define (SCM_SUBR_NAME (subr), subr);
|
||||
scm_define (sname, subr);
|
||||
|
||||
return subr;
|
||||
}
|
||||
|
|
@ -71,40 +80,13 @@ create_gsubr (int define, const char *name,
|
|||
SCM
|
||||
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
|
||||
{
|
||||
return create_gsubr (0, name, req, opt, rst, fcn);
|
||||
return create_gsubr (0, name, req, opt, rst, fcn, NULL);
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
|
||||
{
|
||||
return create_gsubr (1, name, req, opt, rst, fcn);
|
||||
}
|
||||
|
||||
static SCM
|
||||
create_gsubr_with_generic (int define,
|
||||
const char *name,
|
||||
int req,
|
||||
int opt,
|
||||
int rst,
|
||||
SCM (*fcn)(),
|
||||
SCM *gf)
|
||||
{
|
||||
SCM subr;
|
||||
unsigned type;
|
||||
|
||||
type = SCM_GSUBR_MAKTYPE (req, opt, rst);
|
||||
if (SCM_GSUBR_REQ (type) != req
|
||||
|| SCM_GSUBR_OPT (type) != opt
|
||||
|| SCM_GSUBR_REST (type) != rst)
|
||||
scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
|
||||
|
||||
subr = scm_c_make_subr_with_generic (name, scm_tc7_gsubr | (type << 8U),
|
||||
fcn, gf);
|
||||
|
||||
if (define)
|
||||
scm_define (SCM_SUBR_NAME (subr), subr);
|
||||
|
||||
return subr;
|
||||
return create_gsubr (1, name, req, opt, rst, fcn, NULL);
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -115,7 +97,7 @@ scm_c_make_gsubr_with_generic (const char *name,
|
|||
SCM (*fcn)(),
|
||||
SCM *gf)
|
||||
{
|
||||
return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
|
||||
return create_gsubr (0, name, req, opt, rst, fcn, gf);
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -126,7 +108,7 @@ scm_c_define_gsubr_with_generic (const char *name,
|
|||
SCM (*fcn)(),
|
||||
SCM *gf)
|
||||
{
|
||||
return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
|
||||
return create_gsubr (1, name, req, opt, rst, fcn, gf);
|
||||
}
|
||||
|
||||
/* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to
|
||||
|
|
|
|||
|
|
@ -25,6 +25,32 @@
|
|||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
|
||||
|
||||
|
||||
/* Subrs
|
||||
*/
|
||||
|
||||
#define SCM_PRIMITIVE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_gsubr)
|
||||
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PRIMITIVE_P (x) && SCM_SUBR_GENERIC (x))
|
||||
|
||||
#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
|
||||
#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
|
||||
#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
|
||||
#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
|
||||
#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
|
||||
#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
|
||||
#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g))
|
||||
|
||||
/* Return the most suitable subr type for a subr with REQ required arguments,
|
||||
OPT optional arguments, and REST (0 or 1) arguments. This has to be in
|
||||
sync with `create_gsubr ()'. */
|
||||
#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
|
||||
(scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
/* Return an integer describing the arity of GSUBR, a subr of type
|
||||
|
|
|
|||
|
|
@ -41,53 +41,6 @@
|
|||
*/
|
||||
|
||||
|
||||
SCM
|
||||
scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
|
||||
{
|
||||
register SCM z;
|
||||
SCM sname;
|
||||
SCM *meta_info;
|
||||
|
||||
meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
|
||||
sname = scm_from_locale_symbol (name);
|
||||
meta_info[0] = sname;
|
||||
meta_info[1] = SCM_EOL; /* properties */
|
||||
|
||||
z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn,
|
||||
0 /* generic */, (scm_t_bits) meta_info);
|
||||
|
||||
scm_remember_upto_here_1 (sname);
|
||||
|
||||
return z;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
|
||||
{
|
||||
SCM subr = scm_c_make_subr (name, type, fcn);
|
||||
scm_define (SCM_SUBR_NAME (subr), subr);
|
||||
return subr;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_c_make_subr_with_generic (const char *name,
|
||||
long type, SCM (*fcn) (), SCM *gf)
|
||||
{
|
||||
SCM subr = scm_c_make_subr (name, type, fcn);
|
||||
SCM_SET_SUBR_GENERIC_LOC (subr, gf);
|
||||
return subr;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_c_define_subr_with_generic (const char *name,
|
||||
long type, SCM (*fcn) (), SCM *gf)
|
||||
{
|
||||
SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
|
||||
scm_define (SCM_SUBR_NAME (subr), subr);
|
||||
return subr;
|
||||
}
|
||||
|
||||
|
||||
SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return @code{#t} if @var{obj} is a procedure.")
|
||||
|
|
@ -123,21 +76,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/* Only used internally. */
|
||||
int
|
||||
scm_subr_p (SCM obj)
|
||||
{
|
||||
if (SCM_NIMP (obj))
|
||||
switch (SCM_TYP7 (obj))
|
||||
{
|
||||
case scm_tc7_gsubr:
|
||||
return 1;
|
||||
default:
|
||||
;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
SCM_SYMBOL (sym_documentation, "documentation");
|
||||
|
||||
SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
|
||||
|
|
|
|||
|
|
@ -27,36 +27,8 @@
|
|||
|
||||
|
||||
|
||||
|
||||
/* Subrs
|
||||
*/
|
||||
|
||||
#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
|
||||
#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
|
||||
#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
|
||||
#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
|
||||
#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
|
||||
#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
|
||||
#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g))
|
||||
|
||||
/* Return the most suitable subr type for a subr with REQ required arguments,
|
||||
OPT optional arguments, and REST (0 or 1) arguments. This has to be in
|
||||
sync with `create_gsubr ()'. */
|
||||
#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
|
||||
(scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
|
||||
|
||||
|
||||
|
||||
|
||||
SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
|
||||
SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
|
||||
SCM (*fcn)(), SCM *gf);
|
||||
SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)());
|
||||
SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
|
||||
SCM (*fcn)(), SCM *gf);
|
||||
SCM_API SCM scm_procedure_p (SCM obj);
|
||||
SCM_API SCM scm_thunk_p (SCM obj);
|
||||
SCM_API int scm_subr_p (SCM obj);
|
||||
SCM_API SCM scm_procedure_documentation (SCM proc);
|
||||
SCM_API SCM scm_procedure_with_setter_p (SCM obj);
|
||||
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue