Scheme-defined smobs

[prj@po.cwru.edu (Paul Jarc)]

[-- Attachment #1: Type: TEXT/PLAIN, Size: 1027 bytes --]

It seems pointless at first, but I think it might be useful.  The
attached file (tested as an extension with 1.6.4) provides Scheme
bindings for defining smobs - i.e., the "print" and "equalp" functions
can be defined in Scheme.  This might be useful for adding
user-defined cases to equal?.  But I admit my real motivation for
writing this was to enable this gruesome hack:

guile> (define (printer smob-data port state) (system smob-data))
guile> (define generator (make-smob-type "smob-name" printer #f))
guile> (define ls (generator "ls"))
guile> (ls)
"ls"
guile> (ls "ls -a")
guile> (ls)
"ls -a"
guile> ls

... which shows me the output of "ls -a".  So I can use Guile as a
shell with a bit less typing.

Is there interest in adding this to libguile?  (Regardless, I think
the three snarfing macros at the top (along with corresponding
SCM_SMOB_FREE, SCM_SMOB_PRINT, and SCM_SMOB_EQUALP) would be useful
additions to smob.h, though perhaps the name SCM_ SMOB_APPLY is too
similar to the existing SCM_SMOB_APPLY_*.)


paul

[-- Attachment #2: dynsmob.c --]
[-- Type: TEXT/PLAIN, Size: 3096 bytes --]

#include <libguile.h>

#define SCM_SMOB(c_name, scheme_name, size) \
  SCM_SNARF_HERE(static scm_t_bits scm_##c_name##_tag) \
  SCM_SNARF_INIT(scm_##c_name##_tag=scm_make_smob_type((scheme_name), size);)
#define SCM_SMOB_MARK(c_name, arg) \
  SCM_SNARF_HERE(static SCM scm_##c_name##_mark(SCM arg)) \
  SCM_SNARF_INIT(scm_set_smob_mark(scm_##c_name##_tag, scm_##c_name##_mark);)
#define SCM_SMOB_APPLY(c_name, args, req, opt, rest) \
  SCM_SNARF_HERE(static SCM scm_##c_name##_apply args) \
  SCM_SNARF_INIT(scm_set_smob_apply(scm_##c_name##_tag, scm_##c_name##_apply, \
                                    req, opt, rest);)

/* define one static smob, to be used as a generator */

SCM_SMOB(dynsmob_static, "dynsmob", 0);

SCM_SMOB_MARK(dynsmob_static, s_smob)
{
  scm_gc_mark(SCM_CELL_OBJECT_2(s_smob));
  return SCM_CELL_OBJECT_3(s_smob);
}

SCM_SMOB_APPLY(dynsmob_static, (SCM s_smob, SCM s_data), 1, 0, 0)
{
  SCM_RETURN_NEWSMOB2(SCM_CELL_WORD_1(s_smob), s_smob, SCM_UNPACK(s_data));
}

/* these are for Scheme-defined smobs */

static SCM mark_dynsmob(SCM s_smob) {
  SCM const s_type=SCM_CELL_OBJECT_1(s_smob);
  SCM const s_data=SCM_CELL_OBJECT_2(s_smob);
  scm_gc_mark(s_type);
  return s_data;
}

static int print_dynsmob(SCM s_smob, SCM s_port, scm_print_state* pstate) {
  SCM const s_type   =SCM_CELL_OBJECT_1(s_smob);
  SCM const s_printer=SCM_CELL_OBJECT_2(s_type);
  SCM const s_data   =SCM_CELL_OBJECT_2(s_smob);
  (void)pstate; /* silence "unused parameter" warning */
  scm_call_3(s_printer, s_data, s_port, SCM_UNSPECIFIED/*pstate*/);
  return 1;
}

static SCM equalp_dynsmob(SCM s_smob1, SCM s_smob2) {
  SCM const s_type  =SCM_CELL_OBJECT_1(s_smob1);
  SCM const s_equalp=SCM_CELL_OBJECT_3(s_type);
  SCM const s_data1 =SCM_CELL_OBJECT_2(s_smob1);
  SCM const s_data2 =SCM_CELL_OBJECT_2(s_smob2);
  return scm_call_2(s_equalp, s_data1, s_data2);
}

static SCM apply_dynsmob(SCM s_smob, SCM s_newdata) {
  if (SCM_UNBNDP(s_newdata)) {
    SCM const s_data=SCM_CELL_OBJECT_2(s_smob);
    return s_data;
  }
  SCM_SET_CELL_OBJECT_2(s_smob, s_newdata);
  return SCM_UNSPECIFIED;
}

#define FUNC_NAME s_scm_dynsmob_make_smob_type
SCM_DEFINE(scm_dynsmob_make_smob_type, "make-smob-type", 3, 0, 0,
           (SCM s_name, SCM s_printer, SCM s_equalp),
           "Define a new smob type and return a generator for it.")
{
  scm_t_bits tag;
  SCM_VALIDATE_STRING(SCM_ARG1, s_name);
  if (!SCM_FALSEP(s_printer)) SCM_VALIDATE_PROC(SCM_ARG2, s_printer);
  if (!SCM_FALSEP(s_equalp )) SCM_VALIDATE_PROC(SCM_ARG3, s_equalp);
  SCM_STRING_COERCE_0TERMINATION_X(s_name);
  tag=scm_make_smob_type(SCM_STRING_CHARS(s_name), 0);
  scm_set_smob_mark(tag, mark_dynsmob);
  if (!SCM_FALSEP(s_printer)) scm_set_smob_print (tag, print_dynsmob);
  if (!SCM_FALSEP(s_equalp )) scm_set_smob_equalp(tag, equalp_dynsmob);
  scm_set_smob_apply(tag, apply_dynsmob, 0, 1, 0);
  SCM_RETURN_NEWSMOB3(scm_dynsmob_static_tag, tag, SCM_UNPACK(s_printer),
                      SCM_UNPACK(s_equalp));
}
#undef FUNC_NAME

void dynsmob__load__init(void) {
#ifndef SCM_MAGIC_SNARFER
#include "dynsmob.x"
#endif
}

[-- Attachment #3: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel