This is the mail archive of the
guile@sources.redhat.com
mailing list for the Guile project.
Re: Representation of VM programs---applicable smobs?
Mikael Djurfeldt <mdj@mdj.nada.kth.se> writes:
> In order to make things easy, efficient (no unnecessary consing) and
> consistent (with the gh_new_procedure and SCM_DEFINE interfaces) I was
> thinking more like:
>
> scm_set_smob_apply (scm_program_tag, scm_apply_program, 0, 0, 1);
Right. And I think I've done this:
(The patch and the test code are attached at the end)
% guile-apply-smob-test -q
guile> (make-apply000-smob)
#<apply000 8089f00>
guile> ((make-apply000-smob))
()
guile> ((make-apply100-smob) 1)
(1)
guile> ((make-apply110-smob) 1)
(1 #<undefined>)
guile> ((make-apply110-smob) 1 2)
(1 2)
guile> ((make-apply111-smob) 1 2)
(1 2 ())
guile> ((make-apply111-smob) 1 2 3 4)
(1 2 (3 4))
guile> ((make-apply300-smob) 1 2 3)
(1 2 3)
guile> ((make-apply300-smob) 1 2 3 4)
standard input:1:1: In expression ((make-apply300-smob) 1 2 ...):
standard input:1:1: Wrong number of arguments to #<apply300 808e028>
ABORT: (wrong-number-of-args)
Type "(backtrace)" to get more information or "(debug)" to enter the debugger.
> Don't forget the debugging evaluator! (You can look at how one of the
> subrs are handled.)
I think there is nothing to be done. Please fix my code if I'm missing
something...
2000-08-24 Keisuke Nishida <kxn30@po.cwru.edu>
* 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.
(This can be implemented in more efficient way. Maybe someone (me?)
should improve it later...)
Index: eval.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/eval.c,v
retrieving revision 1.168
diff -u -r1.168 eval.c
--- eval.c 2000/08/11 08:42:50 1.168
+++ eval.c 2000/08/24 23:49:19
@@ -2642,6 +2642,10 @@
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 @@
#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 @@
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 @@
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 @@
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 @@
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);
Index: smob.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/smob.c,v
retrieving revision 1.27
diff -u -r1.27 smob.c
--- smob.c 2000/06/29 15:54:58 1.27
+++ smob.c 2000/08/24 23:49:20
@@ -122,6 +122,160 @@
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_2",
+ "Unsupported smob application: ~S",
+ SCM_LIST1 (smob));
+ }
+}
+
long
scm_make_smob_type (char *name, scm_sizet size)
{
@@ -141,6 +295,8 @@
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;
@@ -190,6 +346,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
Index: smob.h
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/smob.h,v
retrieving revision 1.29
diff -u -r1.29 smob.h
--- smob.h 2000/06/20 02:37:53 1.29
+++ smob.h 2000/08/24 23:49:20
@@ -57,6 +57,8 @@
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 @@
#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_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 @@
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.
/* apply-smob.c -- test for applicable smobs */
#include <libguile.h>
long apply000_smob;
long apply100_smob;
long apply010_smob;
long apply001_smob;
long apply200_smob;
long apply110_smob;
long apply020_smob;
long apply101_smob;
long apply011_smob;
long apply300_smob;
long apply210_smob;
long apply120_smob;
long apply030_smob;
long apply201_smob;
long apply021_smob;
long apply111_smob;
SCM_DEFINE (scm_make_apply000_smob, "make-apply000-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply000_smob, 0);
}
SCM_DEFINE (scm_make_apply100_smob, "make-apply100-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply100_smob, 0);
}
SCM_DEFINE (scm_make_apply010_smob, "make-apply010-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply010_smob, 0);
}
SCM_DEFINE (scm_make_apply001_smob, "make-apply001-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply001_smob, 0);
}
SCM_DEFINE (scm_make_apply200_smob, "make-apply200-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply200_smob, 0);
}
SCM_DEFINE (scm_make_apply110_smob, "make-apply110-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply110_smob, 0);
}
SCM_DEFINE (scm_make_apply020_smob, "make-apply020-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply020_smob, 0);
}
SCM_DEFINE (scm_make_apply101_smob, "make-apply101-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply101_smob, 0);
}
SCM_DEFINE (scm_make_apply011_smob, "make-apply011-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply011_smob, 0);
}
SCM_DEFINE (scm_make_apply300_smob, "make-apply300-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply300_smob, 0);
}
SCM_DEFINE (scm_make_apply210_smob, "make-apply210-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply210_smob, 0);
}
SCM_DEFINE (scm_make_apply120_smob, "make-apply120-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply120_smob, 0);
}
SCM_DEFINE (scm_make_apply030_smob, "make-apply030-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply030_smob, 0);
}
SCM_DEFINE (scm_make_apply201_smob, "make-apply201-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply201_smob, 0);
}
SCM_DEFINE (scm_make_apply021_smob, "make-apply021-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply021_smob, 0);
}
SCM_DEFINE (scm_make_apply111_smob, "make-apply111-smob", 0, 0, 0, (), "")
{
SCM_RETURN_NEWSMOB (apply111_smob, 0);
}
SCM apply0 (SCM smob)
{
return SCM_EOL;
}
SCM apply1 (SCM smob, SCM a1)
{
return SCM_LIST1 (a1);
}
SCM apply2 (SCM smob, SCM a1, SCM a2)
{
return SCM_LIST2 (a1, a2);
}
SCM apply3 (SCM smob, SCM a1, SCM a2, SCM rest)
{
return SCM_LIST3 (a1, a2, rest);
}
static void
inner_main (void *closure, int argc, char **argv)
{
apply000_smob = scm_make_smob_type ("apply000", 0);
scm_set_smob_apply (apply000_smob, apply0, 0, 0, 0);
apply100_smob = scm_make_smob_type ("apply100", 0);
scm_set_smob_apply (apply100_smob, apply1, 1, 0, 0);
apply010_smob = scm_make_smob_type ("apply010", 0);
scm_set_smob_apply (apply010_smob, apply1, 0, 1, 0);
apply001_smob = scm_make_smob_type ("apply001", 0);
scm_set_smob_apply (apply001_smob, apply1, 0, 0, 1);
apply200_smob = scm_make_smob_type ("apply200", 0);
scm_set_smob_apply (apply200_smob, apply2, 2, 0, 0);
apply110_smob = scm_make_smob_type ("apply110", 0);
scm_set_smob_apply (apply110_smob, apply2, 1, 1, 0);
apply020_smob = scm_make_smob_type ("apply020", 0);
scm_set_smob_apply (apply020_smob, apply2, 0, 2, 0);
apply101_smob = scm_make_smob_type ("apply101", 0);
scm_set_smob_apply (apply101_smob, apply2, 1, 0, 1);
apply011_smob = scm_make_smob_type ("apply011", 0);
scm_set_smob_apply (apply011_smob, apply2, 0, 1, 1);
apply300_smob = scm_make_smob_type ("apply300", 0);
scm_set_smob_apply (apply300_smob, apply3, 3, 0, 0);
apply210_smob = scm_make_smob_type ("apply210", 0);
scm_set_smob_apply (apply210_smob, apply3, 2, 1, 0);
apply120_smob = scm_make_smob_type ("apply120", 0);
scm_set_smob_apply (apply120_smob, apply3, 1, 2, 0);
apply030_smob = scm_make_smob_type ("apply030", 0);
scm_set_smob_apply (apply030_smob, apply3, 0, 3, 0);
apply201_smob = scm_make_smob_type ("apply201", 0);
scm_set_smob_apply (apply201_smob, apply3, 2, 0, 1);
apply021_smob = scm_make_smob_type ("apply021", 0);
scm_set_smob_apply (apply021_smob, apply3, 0, 2, 1);
apply111_smob = scm_make_smob_type ("apply111", 0);
scm_set_smob_apply (apply111_smob, apply3, 1, 1, 1);
#include "apply-smob.x"
scm_shell (argc, argv);
}
int
main (int argc, char **argv)
{
scm_boot_guile (argc, argv, inner_main, 0);
return 0; /* never reached */
}