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

* smob.h (scm_smob_descriptor): Added apply\' and gsubr_type\'.

Browse source 
* 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 2000-08-25 02:26:22 +00:00
parent 665fc4e600
commit 0717dfd871
4 changed files with 208 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

34
libguile/eval.c
View file

@ -2642,6 +2642,10 @@ evapply:
RETURN (SCM_BOOL_T); RETURN (SCM_BOOL_T);
case scm_tc7_asubr: case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); 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 #ifdef CCLO
case scm_tc7_cclo: case scm_tc7_cclo:
t.arg1 = proc; t.arg1 = proc;
@ -2790,6 +2794,10 @@ evapply:
#else #else
RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL))); RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
#endif #endif
case scm_tc7_smob:
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
goto badfun;
RETURN (scm_smob_apply_1 (proc, t.arg1));
#ifdef CCLO #ifdef CCLO
case scm_tc7_cclo: case scm_tc7_cclo:
arg2 = t.arg1; arg2 = t.arg1;
@ -2908,6 +2916,10 @@ evapply:
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
case scm_tc7_asubr: case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); 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 #ifdef CCLO
cclon: cclon:
case scm_tc7_cclo: case scm_tc7_cclo:
@ -3052,6 +3064,11 @@ evapply:
SCM_CDR (SCM_CDR (debug.info->a.args)))) SCM_CDR (SCM_CDR (debug.info->a.args))))
case scm_tc7_lsubr: case scm_tc7_lsubr:
RETURN (SCM_SUBRF (proc) (debug.info->a.args)) 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 #ifdef CCLO
case scm_tc7_cclo: case scm_tc7_cclo:
goto cclon; goto cclon;
@ -3111,6 +3128,11 @@ evapply:
RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1,
arg2, arg2,
scm_eval_args (x, env, proc)))); 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 #ifdef CCLO
case scm_tc7_cclo: case scm_tc7_cclo:
goto cclon; goto cclon;
@ -3471,6 +3493,18 @@ tail:
proc = arg1; proc = arg1;
} }
RETURN (EVALCAR (proc, args)); 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: case scm_tc7_contin:
SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
scm_call_continuation (proc, arg1); scm_call_continuation (proc, arg1);

3
libguile/procs.c
View file

@ -50,6 +50,7 @@
#include "libguile/objects.h" #include "libguile/objects.h"
#include "libguile/strings.h" #include "libguile/strings.h"
#include "libguile/vectors.h" #include "libguile/vectors.h"
#include "libguile/smob.h"
#include "libguile/validate.h" #include "libguile/validate.h"
#include "libguile/procs.h" #include "libguile/procs.h"
@ -198,6 +199,8 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
#endif #endif
case scm_tc7_pws: case scm_tc7_pws:
return SCM_BOOL_T; return SCM_BOOL_T;
case scm_tc7_smob:
return SCM_BOOL (SCM_SMOB_DESCRIPTOR (obj).apply);
default: default:
return SCM_BOOL_F; return SCM_BOOL_F;
} }

163
libguile/smob.c
View file

@ -122,6 +122,160 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate)
return 1; 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 long
scm_make_smob_type (char *name, scm_sizet size) 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].free = (size == 0 ? scm_free0 : scm_smob_free);
scm_smobs[scm_numsmob].print = scm_smob_print; scm_smobs[scm_numsmob].print = scm_smob_print;
scm_smobs[scm_numsmob].equalp = 0; scm_smobs[scm_numsmob].equalp = 0;
scm_smobs[scm_numsmob].apply = 0;
scm_smobs[scm_numsmob].gsubr_type = 0;
scm_numsmob++; scm_numsmob++;
} }
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
@ -192,6 +348,13 @@ scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM))
scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp; 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 void
scm_set_smob_mfpe (long tc, scm_set_smob_mfpe (long tc,
SCM (*mark) (SCM), SCM (*mark) (SCM),

8
libguile/smob.h
View file

@ -57,6 +57,8 @@ typedef struct scm_smob_descriptor
scm_sizet (*free) (SCM); scm_sizet (*free) (SCM);
int (*print) (SCM exp, SCM port, scm_print_state *pstate); int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM); SCM (*equalp) (SCM, SCM);
SCM (*apply) ();
int gsubr_type;
} scm_smob_descriptor; } scm_smob_descriptor;
@ -112,6 +114,7 @@ do { \
#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name) #define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
#define SCM_SMOB_PREDICATE(tag, obj) (SCM_NIMP (obj) \ #define SCM_SMOB_PREDICATE(tag, obj) (SCM_NIMP (obj) \
&& SCM_TYP16 (obj) == (tag)) && SCM_TYP16 (obj) == (tag))
#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
extern int scm_numsmob; extern int scm_numsmob;
extern scm_smob_descriptor *scm_smobs; 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 scm_sizet scm_smob_free (SCM obj);
extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); 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 /* The following set of functions is the standard way to create new
* SMOB types. * SMOB types.
@ -141,6 +148,7 @@ extern void scm_set_smob_print (long tc, int (*print) (SCM,
SCM, SCM,
scm_print_state*)); scm_print_state*));
extern void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)); 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. /* Functions for registering multiple handler functions simultaneously.