mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

procedures-with-setters implemented in terms of structs

Browse source 
* libguile/tags.h (scm_tc7_pws): No more.

* libguile/procs.c (scm_procedure_with_setter_p)
  (scm_make_procedure_with_setter, scm_procedure, scm_setter): Implement
  procedures-with-setters in terms of applicable structs with setters.

* libguile/procs.h: Remove a big, outdated comment, and the deprecated
  macros.

* libguile/deprecated.h (SCM_PROCEDURE_WITH_SETTER_P, SCM_PROCEDURE)
  (SCM_SETTER): Deprecate these. SCM_PROCEDURE and SCM_SETTER are bad
  names.

* libguile/evalext.c (scm_self_evaluating_p):
* libguile/gc.c (scm_i_tag_name):
* libguile/goops.c: (scm_class_of):
* libguile/print.c (iprin1):
* libguile/procprop.c (scm_i_procedure_arity):
* libguile/procs.c (scm_procedure_p):
* libguile/debug.c (scm_procedure_source): Remove a tc7_pws case.

* libguile/goops.h:
* libguile/goops.c (scm_class_procedure_with_setter): Remove this class;
  it is subsumed by applicable_struct_with_setter.

* libguile/struct.h: Update a comment.

* libguile/vm-i-system.c (call, goto/args, mv-call): Remove PWS cases.
This commit is contained in:
Andy Wingo 2009-12-07 09:56:58 +01:00
parent ce65df9f09
commit ea68d342f1
13 changed files with 40 additions and 134 deletions
Download patch file Download diff file Expand all files Collapse all files

65
libguile/procs.c
View file

@ -101,7 +101,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
|| SCM_STRUCT_APPLICABLE_P (obj)))
break;
case scm_tc7_gsubr:
case scm_tc7_pws:
case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
@ -161,13 +160,16 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
/* Procedure-with-setter
*/
static SCM pws_vtable;
SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a procedure with an\n"
"associated setter procedure.")
#define FUNC_NAME s_scm_procedure_with_setter_p
{
return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
return scm_from_bool (SCM_STRUCTP (obj) && SCM_STRUCT_SETTER_P (obj));
}
#undef FUNC_NAME
@ -180,9 +182,9 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
SCM name, ret;
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
ret = scm_double_cell (scm_tc7_pws,
SCM_UNPACK (procedure),
SCM_UNPACK (setter), 0);
ret = scm_make_struct (pws_vtable, SCM_INUM0,
scm_list_2 (procedure, setter));
/* don't use procedure_name, because don't care enough to do a reverse
lookup */
switch (SCM_TYP7 (procedure)) {
@ -201,51 +203,42 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
(SCM proc),
"Return the procedure of @var{proc}, which must be either a\n"
"procedure with setter, or an applicable struct.")
"Return the procedure of @var{proc}, which must be an\n"
"applicable struct.")
#define FUNC_NAME s_scm_procedure
{
SCM_VALIDATE_NIM (1, proc);
if (SCM_PROCEDURE_WITH_SETTER_P (proc))
return SCM_PROCEDURE (proc);
else if (SCM_STRUCTP (proc))
{
SCM_ASSERT (SCM_PUREGENERICP (proc) || SCM_STRUCT_APPLICABLE_P (proc),
proc, SCM_ARG1, FUNC_NAME);
return proc;
}
SCM_WRONG_TYPE_ARG (1, proc);
return SCM_BOOL_F; /* not reached */
SCM_ASSERT (SCM_STRUCT_APPLICABLE_P (proc), proc, SCM_ARG1, FUNC_NAME);
return SCM_STRUCT_PROCEDURE (proc);
}
#undef FUNC_NAME
SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
SCM
scm_setter (SCM proc)
SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
(SCM proc),
"Return the setter of @var{proc}, which must be an\n"
"applicable struct with a setter.")
#define FUNC_NAME s_scm_setter
{
SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
if (SCM_PROCEDURE_WITH_SETTER_P (proc))
return SCM_SETTER (proc);
else if (SCM_STRUCTP (proc))
{
SCM setter = SCM_BOOL_F;
if (SCM_PUREGENERICP (proc))
setter = SCM_GENERIC_SETTER (proc);
else if (SCM_STRUCT_SETTER_P (proc))
setter = SCM_STRUCT_SETTER (proc);
if (SCM_NIMP (setter))
return setter;
/* fall through */
}
SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
if (SCM_STRUCT_SETTER_P (proc))
return SCM_STRUCT_SETTER (proc);
if (SCM_PUREGENERICP (proc))
/* FIXME: might not be an accessor */
return SCM_GENERIC_SETTER (proc);
SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME
void
scm_init_procs ()
{
SCM setter_vtable_vtable =
scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-vtable>"));
pws_vtable = scm_make_struct (setter_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_from_locale_symbol ("pwpw")));
#include "libguile/procs.x"
}