mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-22 04:30:19 +02:00
* smob.h (scm_smob_descriptor): Added apply\' and gsubr_type\'.
* smob.c (scm_make_smob_type): Initialize `apply\' and `gsubr_type\'. (scm_set_smob_apply): New function. (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2, scm_smob_apply_3): New functions. * eval.c (SCM_CEVAL, SCM_APPLY): Added dispatch for applicable smobs. * procs.c (s_scm_procedure_p): Check applicable smobs.
This commit is contained in:
Keisuke Nishida
parent
665fc4e600
commit
0717dfd871
4 changed files with 208 additions and 0 deletions
|
|
@ -2642,6 +2642,10 @@ evapply:
|
|||
RETURN (SCM_BOOL_T);
|
||||
case scm_tc7_asubr:
|
||||
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
|
||||
case scm_tc7_smob:
|
||||
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
|
||||
goto badfun;
|
||||
RETURN (scm_smob_apply_0 (proc));
|
||||
#ifdef CCLO
|
||||
case scm_tc7_cclo:
|
||||
t.arg1 = proc;
|
||||
|
|
@ -2790,6 +2794,10 @@ evapply:
|
|||
#else
|
||||
RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
|
||||
#endif
|
||||
case scm_tc7_smob:
|
||||
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
|
||||
goto badfun;
|
||||
RETURN (scm_smob_apply_1 (proc, t.arg1));
|
||||
#ifdef CCLO
|
||||
case scm_tc7_cclo:
|
||||
arg2 = t.arg1;
|
||||
|
|
@ -2908,6 +2916,10 @@ evapply:
|
|||
case scm_tc7_rpsubr:
|
||||
case scm_tc7_asubr:
|
||||
RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
|
||||
case scm_tc7_smob:
|
||||
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
|
||||
goto badfun;
|
||||
RETURN (scm_smob_apply_2 (proc, t.arg1, arg2));
|
||||
#ifdef CCLO
|
||||
cclon:
|
||||
case scm_tc7_cclo:
|
||||
|
|
@ -3052,6 +3064,11 @@ evapply:
|
|||
SCM_CDR (SCM_CDR (debug.info->a.args))))
|
||||
case scm_tc7_lsubr:
|
||||
RETURN (SCM_SUBRF (proc) (debug.info->a.args))
|
||||
case scm_tc7_smob:
|
||||
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
|
||||
goto badfun;
|
||||
RETURN (scm_smob_apply_3 (proc, t.arg1, arg2,
|
||||
SCM_CDDR (debug.info->a.args)));
|
||||
#ifdef CCLO
|
||||
case scm_tc7_cclo:
|
||||
goto cclon;
|
||||
|
|
@ -3111,6 +3128,11 @@ evapply:
|
|||
RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1,
|
||||
arg2,
|
||||
scm_eval_args (x, env, proc))));
|
||||
case scm_tc7_smob:
|
||||
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
|
||||
goto badfun;
|
||||
RETURN (scm_smob_apply_3 (proc, t.arg1, arg2,
|
||||
scm_eval_args (x, env, proc)));
|
||||
#ifdef CCLO
|
||||
case scm_tc7_cclo:
|
||||
goto cclon;
|
||||
|
|
@ -3471,6 +3493,18 @@ tail:
|
|||
proc = arg1;
|
||||
}
|
||||
RETURN (EVALCAR (proc, args));
|
||||
case scm_tc7_smob:
|
||||
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
|
||||
goto badproc;
|
||||
if (SCM_NULLP (args))
|
||||
RETURN (scm_smob_apply_0 (proc))
|
||||
else if (SCM_NULLP (SCM_CDR (args)))
|
||||
RETURN (scm_smob_apply_1 (proc, SCM_CAR (args)))
|
||||
else if (SCM_NULLP (SCM_CDDR (args)))
|
||||
RETURN (scm_smob_apply_2 (proc, SCM_CAR (args), SCM_CADR (args)))
|
||||
else
|
||||
RETURN (scm_smob_apply_3 (proc, SCM_CAR (args), SCM_CADR (args),
|
||||
SCM_CDDR (args)));
|
||||
case scm_tc7_contin:
|
||||
SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
|
||||
scm_call_continuation (proc, arg1);
|
||||
|
|
|
|||
|
|
@ -50,6 +50,7 @@
|
|||
#include "libguile/objects.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/smob.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/procs.h"
|
||||
|
|
@ -198,6 +199,8 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
|
|||
#endif
|
||||
case scm_tc7_pws:
|
||||
return SCM_BOOL_T;
|
||||
case scm_tc7_smob:
|
||||
return SCM_BOOL (SCM_SMOB_DESCRIPTOR (obj).apply);
|
||||
default:
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
|
|
|||
163
libguile/smob.c
163
libguile/smob.c
|
|
@ -122,6 +122,160 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
/* {Apply}
|
||||
*/
|
||||
|
||||
SCM
|
||||
scm_smob_apply_0 (SCM smob)
|
||||
{
|
||||
int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
|
||||
switch (type)
|
||||
{
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply ();
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_UNDEFINED);
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_EOL);
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
|
||||
SCM_UNDEFINED,
|
||||
SCM_UNDEFINED);
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
|
||||
SCM_UNDEFINED,
|
||||
SCM_EOL);
|
||||
case SCM_GSUBR_MAKTYPE (0, 3, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
|
||||
SCM_UNDEFINED,
|
||||
SCM_UNDEFINED,
|
||||
SCM_UNDEFINED);
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob,
|
||||
SCM_UNDEFINED,
|
||||
SCM_UNDEFINED,
|
||||
SCM_EOL);
|
||||
default:
|
||||
if (SCM_GSUBR_REQ (type) > 0)
|
||||
scm_wrong_num_args (smob);
|
||||
scm_misc_error ("scm_smob_apply_0",
|
||||
"Unsupported smob application: ~S",
|
||||
SCM_LIST1 (smob));
|
||||
}
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_smob_apply_1 (SCM smob, SCM a1)
|
||||
{
|
||||
int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
|
||||
switch (type)
|
||||
{
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 0):
|
||||
scm_wrong_num_args (smob);
|
||||
case SCM_GSUBR_MAKTYPE (1, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1);
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST1 (a1));
|
||||
case SCM_GSUBR_MAKTYPE (1, 1, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_UNDEFINED);
|
||||
case SCM_GSUBR_MAKTYPE (1, 0, 1):
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_EOL);
|
||||
case SCM_GSUBR_MAKTYPE (1, 2, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 3, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1,
|
||||
SCM_UNDEFINED,
|
||||
SCM_UNDEFINED);
|
||||
case SCM_GSUBR_MAKTYPE (1, 1, 1):
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1,
|
||||
SCM_UNDEFINED,
|
||||
SCM_EOL);
|
||||
default:
|
||||
if (SCM_GSUBR_REQ (type) > 1)
|
||||
scm_wrong_num_args (smob);
|
||||
scm_misc_error ("scm_smob_apply_1",
|
||||
"Unsupported smob application: ~S",
|
||||
SCM_LIST1 (smob));
|
||||
}
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_smob_apply_2 (SCM smob, SCM a1, SCM a2)
|
||||
{
|
||||
int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
|
||||
switch (type)
|
||||
{
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (1, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 0):
|
||||
scm_wrong_num_args (smob);
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, SCM_LIST2 (a1, a2));
|
||||
case SCM_GSUBR_MAKTYPE (2, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (1, 1, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2);
|
||||
case SCM_GSUBR_MAKTYPE (1, 0, 1):
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, SCM_LIST1 (a2));
|
||||
case SCM_GSUBR_MAKTYPE (2, 1, 0):
|
||||
case SCM_GSUBR_MAKTYPE (1, 2, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 3, 0):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_UNDEFINED);
|
||||
case SCM_GSUBR_MAKTYPE (2, 0, 1):
|
||||
case SCM_GSUBR_MAKTYPE (1, 1, 1):
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_EOL);
|
||||
default:
|
||||
if (SCM_GSUBR_REQ (type) > 2)
|
||||
scm_wrong_num_args (smob);
|
||||
scm_misc_error ("scm_smob_apply_2",
|
||||
"Unsupported smob application: ~S",
|
||||
SCM_LIST1 (smob));
|
||||
}
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_smob_apply_3 (SCM smob, SCM a1, SCM a2, SCM rest)
|
||||
{
|
||||
int type = SCM_SMOB_DESCRIPTOR (smob).gsubr_type;
|
||||
switch (type)
|
||||
{
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (1, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 0):
|
||||
case SCM_GSUBR_MAKTYPE (2, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (1, 1, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 0):
|
||||
scm_wrong_num_args (smob);
|
||||
case SCM_GSUBR_MAKTYPE (0, 0, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, scm_cons (a1, scm_cons (a2, rest)));
|
||||
case SCM_GSUBR_MAKTYPE (1, 0, 1):
|
||||
case SCM_GSUBR_MAKTYPE (0, 1, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, scm_cons (a2, rest));
|
||||
case SCM_GSUBR_MAKTYPE (3, 0, 0):
|
||||
case SCM_GSUBR_MAKTYPE (2, 1, 0):
|
||||
case SCM_GSUBR_MAKTYPE (1, 2, 0):
|
||||
case SCM_GSUBR_MAKTYPE (0, 3, 0):
|
||||
if (!SCM_NULLP (SCM_CDR (rest)))
|
||||
scm_wrong_num_args (smob);
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, SCM_CAR (rest));
|
||||
case SCM_GSUBR_MAKTYPE (2, 0, 1):
|
||||
case SCM_GSUBR_MAKTYPE (1, 1, 1):
|
||||
case SCM_GSUBR_MAKTYPE (0, 2, 1):
|
||||
return SCM_SMOB_DESCRIPTOR (smob).apply (smob, a1, a2, rest);
|
||||
default:
|
||||
if (SCM_GSUBR_REQ (type) > 3)
|
||||
scm_wrong_num_args (smob);
|
||||
scm_misc_error ("scm_smob_apply_3",
|
||||
"Unsupported smob application: ~S",
|
||||
SCM_LIST1 (smob));
|
||||
}
|
||||
}
|
||||
|
||||
long
|
||||
scm_make_smob_type (char *name, scm_sizet size)
|
||||
{
|
||||
|
|
@ -141,6 +295,8 @@ scm_make_smob_type (char *name, scm_sizet size)
|
|||
scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free);
|
||||
scm_smobs[scm_numsmob].print = scm_smob_print;
|
||||
scm_smobs[scm_numsmob].equalp = 0;
|
||||
scm_smobs[scm_numsmob].apply = 0;
|
||||
scm_smobs[scm_numsmob].gsubr_type = 0;
|
||||
scm_numsmob++;
|
||||
}
|
||||
SCM_ALLOW_INTS;
|
||||
|
|
@ -192,6 +348,13 @@ scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM))
|
|||
scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst)
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = SCM_GSUBR_MAKTYPE (req, opt, rst);
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_mfpe (long tc,
|
||||
SCM (*mark) (SCM),
|
||||
|
|
|
|||
|
|
@ -57,6 +57,8 @@ typedef struct scm_smob_descriptor
|
|||
scm_sizet (*free) (SCM);
|
||||
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
|
||||
SCM (*equalp) (SCM, SCM);
|
||||
SCM (*apply) ();
|
||||
int gsubr_type;
|
||||
} scm_smob_descriptor;
|
||||
|
||||
|
||||
|
|
@ -112,6 +114,7 @@ do { \
|
|||
#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
|
||||
#define SCM_SMOB_PREDICATE(tag, obj) (SCM_NIMP (obj) \
|
||||
&& SCM_TYP16 (obj) == (tag))
|
||||
#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
|
||||
|
||||
extern int scm_numsmob;
|
||||
extern scm_smob_descriptor *scm_smobs;
|
||||
|
|
@ -124,6 +127,10 @@ extern scm_sizet scm_free0 (SCM ptr);
|
|||
extern scm_sizet scm_smob_free (SCM obj);
|
||||
extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
|
||||
|
||||
extern SCM scm_smob_apply_0 (SCM smob);
|
||||
extern SCM scm_smob_apply_1 (SCM smob, SCM a1);
|
||||
extern SCM scm_smob_apply_2 (SCM smob, SCM a1, SCM a2);
|
||||
extern SCM scm_smob_apply_3 (SCM smob, SCM a1, SCM a2, SCM rest);
|
||||
|
||||
/* The following set of functions is the standard way to create new
|
||||
* SMOB types.
|
||||
|
|
@ -141,6 +148,7 @@ extern void scm_set_smob_print (long tc, int (*print) (SCM,
|
|||
SCM,
|
||||
scm_print_state*));
|
||||
extern void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM));
|
||||
extern void scm_set_smob_apply (long tc, SCM (*apply) (), int req, int opt, int rst);
|
||||
|
||||
|
||||
/* Functions for registering multiple handler functions simultaneously.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue