summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-01-05 16:15:14 +0100
committerAndy Wingo <wingo@pobox.com>2010-01-05 16:15:14 +0100
commit9fdf9fd3ea7130fd85eaf0a333a965ac4d2b07c3 (patch)
tree31ac376b1ce4cfb2757e222d39794577378f8c2f /libguile
parente809758a7e0f3f63162a0a9064b95bd1c1d10628 (diff)
downloadguile-9fdf9fd3ea7130fd85eaf0a333a965ac4d2b07c3.tar.gz
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.
Diffstat (limited to 'libguile')
-rw-r--r--libguile/deprecated.h5
-rw-r--r--libguile/goops.c13
-rw-r--r--libguile/gsubr.c52
-rw-r--r--libguile/gsubr.h26
-rw-r--r--libguile/procs.c62
-rw-r--r--libguile/procs.h28
6 files changed, 53 insertions, 133 deletions
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 671f40f83..5b7c9a2ac 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -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
diff --git a/libguile/goops.c b/libguile/goops.c
index 983fa5924..a703e7a7e 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -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));
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 24ba6700c..70be51b91 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -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
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index e75658d1c..74a08a242 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -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
diff --git a/libguile/procs.c b/libguile/procs.c
index 6c0391123..e94037828 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -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,
diff --git a/libguile/procs.h b/libguile/procs.h
index a832cd06f..a4dfaff3c 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -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);