mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

(scm_c_make_subr, scm_c_define_subr,

Browse source 
scm_c_make_subr_with_generic, scm_c_define_subr_with_generic): New
functions.  They replace scm_make_subr, scm_make_subr_opt and
scm_make_subr_with_generic.  The `make' variants only create the
subr object, while the `define' variants also put it into the
current module.  Changed all callers.
(scm_make_subr, scm_make_subr_opt, scm_make_subr_with_generic):
Deprecated.
This commit is contained in:
Marius Vollmer 2001-05-20 00:34:25 +00:00
parent 9d78586faf
commit c88a8162c4
2 changed files with 74 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

79
libguile/procs.c
View file

@ -50,6 +50,7 @@
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/smob.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/procs.h"
@ -70,10 +71,8 @@ int scm_subr_table_size = 0;
int scm_subr_table_room = 800;
SCM
scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
scm_c_make_subr (const char *name, int type, SCM (*fcn) ())
{
SCM symbol;
SCM var;
register SCM z;
int entry;
@ -89,18 +88,11 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
scm_subr_table_room = new_size;
}
symbol = scm_str2symbol (name);
SCM_NEWCELL (z);
if (set)
var = scm_sym2var (symbol, scm_current_module_lookup_closure (),
SCM_BOOL_T);
else
var = SCM_BOOL_F;
entry = scm_subr_table_size;
scm_subr_table[entry].handle = z;
scm_subr_table[entry].name = symbol;
scm_subr_table[entry].name = scm_str2symbol (name);
scm_subr_table[entry].generic = 0;
scm_subr_table[entry].properties = SCM_EOL;
@ -108,12 +100,17 @@ scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
SCM_SET_CELL_TYPE (z, (entry << 8) + type);
scm_subr_table_size++;
if (set)
SCM_VARIABLE_SET (var, z);
return z;
}
SCM
scm_c_define_subr (const char *name, int type, SCM (*fcn) ())
{
SCM subr = scm_c_make_subr (name, type, fcn);
scm_define (SCM_SUBR_ENTRY(subr).name, subr);
return subr;
}
/* This function isn't currently used since subrs are never freed. */
/* *fixme* Need mutex here. */
void
@ -126,17 +123,21 @@ scm_free_subr_entry (SCM subr)
scm_subr_table_size--;
}
SCM
scm_make_subr (const char *name, int type, SCM (*fcn) ())
SCM
scm_c_make_subr_with_generic (const char *name,
int type, SCM (*fcn) (), SCM *gf)
{
return scm_make_subr_opt (name, type, fcn, 1);
SCM subr = scm_c_make_subr (name, type, fcn);
SCM_SUBR_ENTRY(subr).generic = gf;
return subr;
}
SCM
scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf)
scm_c_define_subr_with_generic (const char *name,
int type, SCM (*fcn) (), SCM *gf)
{
SCM subr = scm_make_subr_opt (name, type, fcn, 1);
scm_subr_table[scm_subr_table_size - 1].generic = gf;
SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
scm_define (SCM_SUBR_ENTRY(subr).name, subr);
return subr;
}
@ -402,6 +403,42 @@ scm_init_procs ()
#endif
}
#if SCM_DEBUG_DEPRECATED == 0
SCM
scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
{
scm_c_issue_deprecation_warning
("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or "
"`scm_c_define_subr' instead.");
if (set)
return scm_c_define_subr (name, type, fcn);
else
return scm_c_make_subr (name, type, fcn);
}
SCM
scm_make_subr (const char *name, int type, SCM (*fcn) ())
{
scm_c_issue_deprecation_warning
("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead.");
return scm_c_define_subr (name, type, fcn);
}
SCM
scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf)
{
scm_c_issue_deprecation_warning
("`scm_make_subr_with_generic' is deprecated. Use "
"`scm_c_define_subr_with_generic' instead.");
return scm_c_define_subr_with_generic (name, type, fcn);
}
#endif /* !SCM_DEBUG_DEPRECATION */
/*
Local Variables:
c-file-style: "gnu"

25
libguile/procs.h
View file

@ -161,15 +161,12 @@ extern int scm_subr_table_room;
extern void scm_mark_subr_table (void);
extern void scm_free_subr_entry (SCM subr);
extern SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
extern SCM scm_make_subr_with_generic (const char *name,
int type,
SCM (*fcn) (),
SCM *gf);
extern SCM scm_make_subr_opt (const char *name,
int type,
SCM (*fcn) (),
int set);
extern SCM scm_c_make_subr (const char *name, int type, SCM (*fcn)());
extern SCM scm_c_make_subr_with_generic (const char *name, int type,
SCM (*fcn)(), SCM *gf);
extern SCM scm_c_define_subr (const char *name, int type, SCM (*fcn)());
extern SCM scm_c_define_subr_with_generic (const char *name, int type,
SCM (*fcn)(), SCM *gf);
extern SCM scm_makcclo (SCM proc, long len);
extern SCM scm_procedure_p (SCM obj);
extern SCM scm_closure_p (SCM obj);
@ -193,6 +190,16 @@ extern SCM scm_make_cclo (SCM proc, SCM len);
#define SCM_SUBR_DOC(x) SCM_BOOL_F
extern SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
extern SCM scm_make_subr_with_generic (const char *name,
int type,
SCM (*fcn) (),
SCM *gf);
extern SCM scm_make_subr_opt (const char *name,
int type,
SCM (*fcn) (),
int set);
#endif /* SCM_DEBUG_DEPRECATED == 0 */
#endif /* SCM_PROCS_H */