unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [patch] subordinate SMOBs with GOOPS superclasses
@ 2007-11-27  6:57 Marco Maggi
  2007-12-05 22:19 ` Andy Wingo
  0 siblings, 1 reply; 12+ messages in thread
From: Marco Maggi @ 2007-11-27  6:57 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 614 bytes --]

The attached patch documents the creation of
a GOOPS class whenever a new SMOB type is
defined and GOOPS has been already loaded.

Additionally it adds a special SMOB type that
dispatches function invocations to a user defined
subordinate SMOB. This allows to overcome the
hard coded limit on SMOB number at the cost
of some functions call.

The subordinate SMOB allows to select a list
of superclasses, so that the sub-SMOB's class
appears to be derived from already existent classes.

A standalone test is included.

If the thing is accepted I can sign and send the
licence piece of paper.



[-- Attachment #2: patch-subsmob --]
[-- Type: application/octet-stream, Size: 27623 bytes --]

diff -Naur guile-1.8.3-original/doc/ref/api-smobs.texi guile-1.8.3-patch-subsmob/doc/ref/api-smobs.texi
--- guile-1.8.3-original/doc/ref/api-smobs.texi	2007-05-09 22:22:03.000000000 +0200
+++ guile-1.8.3-patch-subsmob/doc/ref/api-smobs.texi	2007-11-26 19:43:21.000000000 +0100
@@ -8,6 +8,12 @@
 @node Smobs
 @section Smobs
 
+
+@menu
+* Subsmobs::                    Subordinate smobs.
+@end menu
+
+
 This chapter contains reference information related to defining and
 working with smobs.  See @ref{Defining New Types (Smobs)} for a
 tutorial-like introduction to smobs.
@@ -31,6 +37,11 @@
 immediately followed by calls to one or several of
 @code{scm_set_smob_mark}, @code{scm_set_smob_free},
 @code{scm_set_smob_print}, and/or @code{scm_set_smob_equalp}.
+
+If GOOPS is loaded when @code{scm_make_smob_type} is invoked: a new
+GOOPS class is created, with @code{top} as superclass, to represent the
+smob type. This allows GOOPS to dispatch methods based on the type of
+the smob.
 @end deftypefun
 
 @deftypefn {C Function} void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM obj))
@@ -193,6 +204,179 @@
 other objects.  This function simply returns @var{x}'s first data word.
 @end deftypefun
 
+
+@c ------------------------------------------------------------
+@node Subsmobs
+@subsection Subordinate smobs
+
+
+A special smob type is implemented to overcome the 255 limit on the
+number of smob types. Its procedures dispatch the call to procedures
+referenced by a subsmob descriptor.
+
+If GOOPS is loaded when @code{scm_make_sub_smob_type} is invoked to
+declare the new subsmob type: a new GOOPS class is created, optionally
+with a list of superclasses, to represent the smob type. This allows
+GOOPS to dispatch methods based on the type of the smob.
+
+
+@deftp {Struct Typedef} scm_sub_smob_descriptor
+The type of subsmob descriptor structure. Public fields:
+
+@table @code
+@item const char * name
+a statically--allocated zero--terminated string representing the subsmob
+identifier; it is used by the print function and to create the GOOPS
+class symbol: if the value is @code{mine}, the class' symbol is
+@code{<mine>};
+
+@item size_t client_data_size;
+analogous to the @var{size} argument to @code{scm_make_smob_type};
+
+@item size_t (* free) (SCM smob)
+pointer to a free function that works like the one of a normal smob; can
+be @code{NULL}, in which case: if @code{client_data_size} is not zero
+@code{scm_gc_free} is used to free the client data structure when the
+smob is garbage collected; the string referenced by @code{name} is used
+as @var{what} argument to @code{scm_gc_free};
+
+@item SCM (* equalp) (SCM smob_a, SCM smob_b)
+pointer to a comparison function that works like the one of a normal
+smob; if it is @code{NULL}: @code{scm_eq_p} is used to compare the
+smobs;
+
+@item SCM (* mark) (SCM smob)
+pointer to a mark function that works like the one of a normal
+smob; can be @code{NULL};
+
+@item int (* print) (SCM smob, SCM s_port, scm_print_state * pstate)
+pointer to a print function that works like the one of a normal smob;
+can be @code{NULL};
+
+@item SCM class
+this field must be initialised to @code{SCM_BOOL_F}; Guile will set it
+to a GOOPS class representing the subsmob type, and will mark it as
+permanent object;
+
+@item SCM list_of_supers
+a list of GOOPS classes to be used as base classes for the subsmob
+class; this field must be initialised to @code{SCM_EOL} when defining
+the structure and, if needed, reset to the list of classes in an
+initialisation function; if it is left to @code{SCM_EOL}: the base class
+of the subsmob type will be @code{<top>}; it is our responsibility to
+mark the list as a permanent object (using @code{scm_permanent_object}).
+@end table
+@end deftp
+
+
+@deftypefun void scm_make_sub_smob_type (scm_sub_smob_descriptor * descriptor)
+Declare a new subsmob type according to the the structure referenced by
+@var{descriptor}.
+@end deftypefun
+
+
+@deftypefn {C Macro} int SCM_SUB_SMOB_PREDICATE (SCM obj)
+Evaluate to true if @var{obj} is a subsmob.
+@end deftypefn
+
+
+@deftypefn {C Macro} {scm_sub_smob_descriptor *} SCM_SUB_SMOB_DESCRIPTOR (SCM obj)
+Return a pointer to the subsmob type descriptor of @var{obj}. @var{obj}
+must be a subsmob.
+@end deftypefn
+
+
+@deftypefn {C Macro} void SCM_NEWSUBSMOB (SCM value, scm_sub_smob_descriptor * type, void * data)
+Make @var{value} contain a subsmob instance of the type with descriptor
+@var{type} and smob data @var{data}.
+@end deftypefn
+
+
+@deftypefn {C Macro} SCM SCM_RETURN_NEWSUBSMOB (scm_sub_smob_descriptor * type, void * data)
+This macro expands to a block of code that creates a smob instance of
+the type descriptor @var{type} and smob data @var{data}, as with
+@code{SCM_NEWSUBSMOB}, etc., and causes the surrounding function to
+return that @code{SCM} value.  It should be the last piece of code in a
+block.
+@end deftypefn
+
+
+@subsubsection Examples: a wrapper for @code{int}
+
+
+@noindent
+Let's say that we want to define a new subordinate smob that wraps an
+integer and has @code{<number>} as base class. We can write the driver
+like this:
+
+@example
+typedef struct client_data_t @{
+  int   n;
+@} client_data_t;
+
+#define MY_INTEGER_DATA(SMOB) ((client_data_t *)SCM_SMOB_DATA(SMOB))
+
+static SCM my_integer_equalp(SCM smob_a, SCM smob_b);
+static int my_integer_print (SCM smob, SCM s_port,
+                             scm_print_state * pstate SCM_UNUSED);
+
+static scm_t_sub_smob_descriptor my_integer_driver = @{
+  .name                 = "my-integer",
+  .client_data_size     = sizeof(client_data_t),
+  .free                 = NULL,
+  .equalp               = my_integer_equalp,
+  .mark                 = NULL,
+  .print                = my_integer_print,
+  .class                = SCM_BOOL_F,
+  .list_of_supers       = SCM_EOL
+@};
+
+SCM
+my_integer_equalp (SCM smob_a, SCM smob_b)
+@{
+  int   a = MY_INTEGER_DATA(smob_a)->n;
+  int   b = MY_INTEGER_DATA(smob_b)->n;
+
+  return scm_from_bool(a == b);
+@}
+int
+my_integer_print (SCM smob, SCM s_port,
+                  scm_print_state * pstate SCM_UNUSED)
+@{
+  scm_puts("#<", s_port);
+  scm_puts(my_integer_driver.name, s_port);
+  scm_puts(" - ", s_port);
+  scm_display(scm_from_int(MY_INTEGER_DATA(smob)->n), s_port);
+  scm_putc('>', s_port);
+  return 1;
+@}
+@end example
+
+@noindent
+we need an initialization function in which we put:
+
+@example
+SCM   s_number_class, s_list_of_supers;
+
+s_number_class   = scm_variable_ref(scm_c_lookup("<number>"));
+s_list_of_supers = scm_list_1(s_number_class);
+s_list_of_supers = scm_permanent_object(s_list_of_supers);
+
+my_integer_driver.list_of_supers = s_list_of_supers;
+scm_make_sub_smob_type(&my_integer_driver);
+scm_c_define(my_integer_driver.name, my_integer_driver.class);
+@end example
+
+The library must be loaded in a module @strong{after} loading GOOPS in
+the same module.  Then we can define methods:
+
+@example
+(define-method (do-something (o <my-integer>))
+  ...)
+@end example
+
+
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
diff -Naur guile-1.8.3-original/libguile/goops.c guile-1.8.3-patch-subsmob/libguile/goops.c
--- guile-1.8.3-original/libguile/goops.c	2007-07-11 00:27:36.000000000 +0200
+++ guile-1.8.3-patch-subsmob/libguile/goops.c	2007-11-26 19:14:20.000000000 +0100
@@ -230,6 +230,13 @@
 
 	case scm_tc7_smob:
 	  {
+	    if (SCM_SMOB_PREDICATE(scm_multi_smob_driver, x))
+	      {
+		SCM class = (SCM_SUB_SMOB_DESCRIPTOR(x))->class;
+
+		if (scm_is_true(class))
+		  return class;
+	      }
 	    scm_t_bits type = SCM_TYP16 (x);
 	    if (type != scm_tc16_port_with_ps)
 	      return scm_smob_class[SCM_TC2SMOBNUM (type)];
@@ -244,7 +251,9 @@
 				 : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
 	case scm_tcs_struct:
 	  if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
-	    return SCM_CLASS_OF (x);
+	    {
+	      return SCM_CLASS_OF (x);
+	    }
 	  else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
 	    {
 	      /* Goops object */
@@ -252,6 +261,7 @@
 		scm_change_object_class (x,
 					 SCM_CLASS_OF (x),         /* old */
 					 SCM_OBJ_CLASS_REDEF (x)); /* new */
+
 	      return SCM_CLASS_OF (x);
 	    }
 	  else
@@ -2631,6 +2641,17 @@
 					       : scm_class_top),
 				   applicablep);
 }
+SCM
+scm_make_extended_class_with_supers (char const *type_name, SCM list_of_supers)
+{
+  return make_class_from_template ("<%s>",
+				   type_name,
+				   ((SCM_UNSPECIFIED != list_of_supers) &&
+				    (SCM_EOL         != list_of_supers))
+				   ? list_of_supers
+				   : scm_list_1(scm_class_top),
+				   0);
+}
 
 void
 scm_i_inherit_applicable (SCM c)
diff -Naur guile-1.8.3-original/libguile/objects.h guile-1.8.3-patch-subsmob/libguile/objects.h
--- guile-1.8.3-original/libguile/objects.h	2007-05-09 22:22:03.000000000 +0200
+++ guile-1.8.3-patch-subsmob/libguile/objects.h	2007-11-14 18:10:31.000000000 +0100
@@ -181,6 +181,7 @@
 
 /* Goops functions. */
 SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
+SCM_API SCM scm_make_extended_class_with_supers (char const *type_name, SCM list_of_supers);
 SCM_API void scm_i_inherit_applicable (SCM c);
 SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
 SCM_API void scm_change_object_class (SCM, SCM, SCM);
diff -Naur guile-1.8.3-original/libguile/smob.c guile-1.8.3-patch-subsmob/libguile/smob.c
--- guile-1.8.3-original/libguile/smob.c	2007-05-09 22:22:03.000000000 +0200
+++ guile-1.8.3-patch-subsmob/libguile/smob.c	2007-11-26 16:49:22.000000000 +0100
@@ -30,6 +30,7 @@
 #include "libguile/objects.h"
 #include "libguile/goops.h"
 #include "libguile/ports.h"
+#include "libguile/eq.h"
 
 #ifdef HAVE_MALLOC_H
 #include <malloc.h>
@@ -49,6 +50,8 @@
 long scm_numsmob;
 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
 
+scm_t_bits scm_multi_smob_driver;
+
 /* Lower 16 bit of data must be zero. 
 */
 void
@@ -315,6 +318,16 @@
 }
 #undef FUNC_NAME
 
+void
+scm_make_sub_smob_type (scm_t_sub_smob_descriptor * descriptor)
+#define FUNC_NAME "scm_make_sub_smob_type"
+{
+  /* Make a class object if Goops is present. */
+  if (scm_smob_class)
+    descriptor->class =
+      scm_permanent_object(scm_make_extended_class_with_supers(descriptor->name, descriptor->list_of_supers));
+}
+#undef FUNC_NAME
 
 void
 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
@@ -485,6 +498,62 @@
   return 1;
 }
 
+\f
+/* Multi-SMOB functions */
+
+static size_t
+multi_smob_free (SCM smob)
+{
+  scm_t_sub_smob_descriptor *	driver = SCM_SUB_SMOB_DESCRIPTOR(smob);
+
+  if (driver->free)
+    return driver->free(smob);
+  else if (driver->client_data_size) {
+    void *	data = (void *)SCM_SMOB_DATA(smob);
+    scm_gc_free(data, driver->client_data_size, driver->name);
+  }
+  return 0;
+}
+static SCM
+multi_smob_equalp (SCM smob_a, SCM smob_b)
+{
+  scm_t_sub_smob_descriptor *	driver_a = SCM_SUB_SMOB_DESCRIPTOR(smob_a);
+  scm_t_sub_smob_descriptor *	driver_b = SCM_SUB_SMOB_DESCRIPTOR(smob_b);
+
+  if (driver_a == driver_b)
+    return (driver_a->equalp)? driver_a->equalp(smob_a, smob_b) : scm_eq_p(smob_a, smob_b);
+  else
+    return SCM_BOOL_F;
+}
+static SCM
+multi_smob_mark (SCM smob)
+{
+  scm_t_sub_smob_descriptor *	driver = SCM_SUB_SMOB_DESCRIPTOR(smob);
+
+  return (driver->mark)? driver->mark(smob) : SCM_BOOL_F;
+}
+static int
+multi_smob_print (SCM smob, SCM s_port, scm_print_state * pstate)
+{
+  scm_t_sub_smob_descriptor *	driver = SCM_SUB_SMOB_DESCRIPTOR(smob);
+
+  if (driver->print)
+    return driver->print(smob, s_port, pstate);
+  else
+    {
+      scm_puts("#<", s_port);
+      scm_puts(driver->name, s_port);
+      scm_puts(" - ", s_port);
+      scm_display(scm_from_long(SCM_SMOBNUM(smob)), s_port);
+      scm_puts(" ", s_port);
+      scm_display(scm_from_ulong((unsigned long)smob), s_port);
+      scm_putc('>', s_port);
+      return 1;
+    }
+}
+
+\f
+
 void
 scm_smob_prehistory ()
 {
@@ -511,8 +580,15 @@
   /* WARNING: This scm_make_smob_type call must be done first.  */
   tc = scm_make_smob_type ("free", 0);
   scm_set_smob_print (tc, free_print);
+
+  scm_multi_smob_driver = scm_make_smob_type("MultiSMOB", 0);
+  scm_set_smob_free	(scm_multi_smob_driver, multi_smob_free);
+  scm_set_smob_equalp	(scm_multi_smob_driver, multi_smob_equalp);
+  scm_set_smob_mark	(scm_multi_smob_driver, multi_smob_mark);
+  scm_set_smob_print	(scm_multi_smob_driver, multi_smob_print);
 }
 
+
 /*
   Local Variables:
   c-file-style: "gnu"
diff -Naur guile-1.8.3-original/libguile/smob.h guile-1.8.3-patch-subsmob/libguile/smob.h
--- guile-1.8.3-original/libguile/smob.h	2007-05-09 22:22:03.000000000 +0200
+++ guile-1.8.3-patch-subsmob/libguile/smob.h	2007-11-15 17:51:23.000000000 +0100
@@ -119,6 +119,35 @@
 
 \f
 
+typedef struct scm_t_sub_smob_descriptor {
+  const char *	name;
+  size_t	client_data_size;
+  size_t	(* free) (SCM obj);
+  SCM		(* equalp) (SCM obj_a, SCM obj_b);
+  SCM		(* mark) (SCM obj);
+  int		(* print) (SCM smob, SCM s_port, scm_print_state * pstate);
+  SCM		class;
+  SCM		list_of_supers;
+} scm_t_sub_smob_descriptor;
+
+#define SCM_SUB_SMOB_DESCRIPTOR(SMOB)	((scm_t_sub_smob_descriptor *)SCM_SMOB_DATA_2(SMOB))
+
+SCM_API scm_t_bits scm_multi_smob_driver;
+
+#define SCM_SUB_SMOB_PREDICATE(SMOB)		\
+		SCM_SMOB_PREDICATE(scm_multi_smob_driver, SMOB)
+
+#define SCM_NEWSUBSMOB(SMOB,DESCRIPTOR,DATA)	\
+		SCM_NEWSMOB2((SMOB), scm_multi_smob_driver, (DATA), (DESCRIPTOR));
+
+#define SCM_RETURN_NEWSUBSMOB(DESCRIPTOR,DATA) \
+  do { SCM __SCM_smob_answer; \
+       SCM_NEWSUBSMOB (__SCM_smob_answer, (DESCRIPTOR), (DATA)); \
+       return __SCM_smob_answer; \
+  } while (0)
+
+\f
+
 SCM_API SCM scm_mark0 (SCM ptr);
 SCM_API SCM scm_markcdr (SCM ptr);
 SCM_API size_t scm_free0 (SCM ptr);
@@ -134,6 +163,7 @@
  */
 
 SCM_API scm_t_bits scm_make_smob_type (char const *name, size_t size);
+SCM_API void scm_make_sub_smob_type (scm_t_sub_smob_descriptor * descriptor);
 
 SCM_API void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM));
 SCM_API void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM));
diff -Naur guile-1.8.3-original/test-suite/standalone/Makefile.am guile-1.8.3-patch-subsmob/test-suite/standalone/Makefile.am
--- guile-1.8.3-original/test-suite/standalone/Makefile.am	2007-10-10 22:17:45.000000000 +0200
+++ guile-1.8.3-patch-subsmob/test-suite/standalone/Makefile.am	2007-11-26 16:03:48.000000000 +0100
@@ -107,6 +107,16 @@
 check_SCRIPTS += test-use-srfi
 TESTS += test-use-srfi
 
+# test-subsmob
+noinst_LTLIBRARIES += libtest-subsmob.la
+libtest_subsmob_la_SOURCES = test-subsmob-lib.c test-subsmob-lib.x
+libtest_subsmob_la_CFLAGS = ${test_cflags}
+libtest_subsmob_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so
+libtest_subsmob_la_LIBADD = ${top_builddir}/libguile/libguile.la
+BUILT_SOURCES += test-subsmob-lib.x
+check_SCRIPTS += test-subsmob
+TESTS += test-subsmob
+
 all-local:
 	cd ${srcdir} && chmod u+x ${check_SCRIPTS}
 
diff -Naur guile-1.8.3-original/test-suite/standalone/test-subsmob guile-1.8.3-patch-subsmob/test-suite/standalone/test-subsmob
--- guile-1.8.3-original/test-suite/standalone/test-subsmob	1970-01-01 01:00:00.000000000 +0100
+++ guile-1.8.3-patch-subsmob/test-suite/standalone/test-subsmob	2007-11-26 19:40:09.000000000 +0100
@@ -0,0 +1,160 @@
+#!/bin/sh
+exec guile -s "$0" "$@"
+!#
+
+;;To run only this test: from the top source directory of Guile:
+;;
+;;	$ make ; (cd test-suite/standalone ; make check)
+;;
+
+(use-modules (oop goops)
+	     (ice-9 regex)
+	     (ice-9 pretty-print))
+
+(load-extension "libtest-subsmob" "libtest_subsmob_init")
+
+;; ------------------------------------------------------------
+
+(define-method (upon-number (o <top>))
+  #f)
+
+(define-method (upon-number (o <number>))
+  #t)
+
+(define-method (upon-integer (o <top>))
+  #f)
+
+(define-method (upon-double (o <top>))
+  #f)
+
+(define-method (upon-wrapper (o <top>))
+  #f)
+
+;; ------------------------------------------------------------
+
+; (pretty-print <my-integer>)
+; (pretty-print (class-precedence-list <my-integer>))
+
+(define-method (upon-integer (o <my-integer>))
+  #t)
+
+(let ((a	(make-my-integer 123))
+      (b	(make-my-integer 123))
+      (c	(make-my-integer 456)))
+
+  ;;Forcing GC causes the mark function to be invoked.
+  (gc)
+
+  (if (not (equal? a b))
+      (error 'should-be-equal "error in equalp"))
+  (if (equal? a c)
+      (error 'should-be-not-equal "error in equalp"))
+
+  (if (not (string= "#<my-integer - 123>" (object->string a display)))
+      (error 'bad-string-rep "error in my-integer print function"))
+
+  (if (not (eq? (class-of a) <my-integer>))
+      (error 'bad-smob-class "error in my-integer class-of"))
+
+  (if (not (is-a? a <my-integer>))
+      (error 'bad-smob-class "error in my-integer class"))
+
+  (if (not (is-a? a <number>))
+      (error 'bad-smob-class "error in my-integer supers"))
+
+  (if (not (upon-number a))
+      (error 'bad-method-dispatch "error in dispatching for <number>"))
+
+  (if (not (upon-integer a))
+      (error 'bad-method-dispatch "error in dispatching for <my-integer>")))
+
+;;Forcing GC causes the free function to be invoked.
+(gc)
+(gc)
+
+;; ------------------------------------------------------------
+
+; (pretty-print <my-double>)
+; (pretty-print (class-precedence-list <my-double>))
+
+(define-method (upon-double (o <my-double>))
+  #t)
+
+(let ((a	(make-my-double 123))
+      (b	(make-my-double 123))
+      (c	(make-my-double 456)))
+
+  ;;Forcing GC causes the mark function to be invoked.
+  (gc)
+
+  (if (equal? a b)
+      (error 'should-be-not-equal "error in equalp"))
+  (if (not (equal? a a))
+      (error 'should-be-equal "error in equalp"))
+
+  (if (not (string-match "#<my-double - [0-9a-f]+ [0-9a-f]+>" (object->string a display)))
+      (error 'bad-string-rep "error in my-double print function"))
+
+  (if (not (eq? (class-of a) <my-double>))
+      (error 'bad-smob-class "error in my-double class-of"))
+
+  (if (not (is-a? a <my-double>))
+      (error 'bad-smob-class "error in my-double class"))
+
+  (if (not (is-a? a <number>))
+      (error 'bad-smob-class "error in my-double supers"))
+
+  (if (not (upon-number a))
+      (error 'bad-method-dispatch "error in dispatching for <number>"))
+
+  (if (not (upon-double a))
+      (error 'bad-method-dispatch "error in dispatching for <my-double>")))
+
+;;Forcing GC causes the free function to be invoked.
+(gc)
+(gc)
+
+;; ------------------------------------------------------------
+
+; (pretty-print <my-wrapper>)
+; (pretty-print (class-precedence-list <my-wrapper>))
+
+(define-method (upon-wrapper (o <my-wrapper>))
+  #t)
+
+(let ((a	(make-my-wrapper 123))
+      (b	(make-my-wrapper 123))
+      (c	(make-my-wrapper 456)))
+
+  ;;Forcing GC causes the mark function to be invoked.
+  (gc)
+
+  (if (not (equal? a b))
+      (error 'should-be-equal "error in equalp"))
+  (if (equal? a c)
+      (error 'should-be-not-equal "error in equalp"))
+
+  (if (not (string= "#<my-wrapper - 123>" (object->string a display)))
+      (error 'bad-string-rep "error in my-wrapper print function"))
+
+  (if (not (eq? (class-of a) <my-wrapper>))
+      (error 'bad-smob-class "error in my-wrapper class-of"))
+
+  (if (not (is-a? a <my-wrapper>))
+      (error 'bad-smob-class "error in my-wrapper class"))
+
+  (if (is-a? a <number>)
+      (error 'bad-smob-class "error in my-wrapper supers"))
+
+  (if (not (upon-wrapper a))
+      (error 'bad-method-dispatch "error in dispatching for <my-wrapper>")))
+
+;;Forcing GC causes the free function to be invoked.
+(gc)
+(gc)
+
+
+
+;; Local Variables:
+;; mode: scheme
+;; End:
diff -Naur guile-1.8.3-original/test-suite/standalone/test-subsmob-lib.c guile-1.8.3-patch-subsmob/test-suite/standalone/test-subsmob-lib.c
--- guile-1.8.3-original/test-suite/standalone/test-subsmob-lib.c	1970-01-01 01:00:00.000000000 +0100
+++ guile-1.8.3-patch-subsmob/test-suite/standalone/test-subsmob-lib.c	2007-11-26 19:41:30.000000000 +0100
@@ -0,0 +1,248 @@
+/* Copyright (C) 2007 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+/** ------------------------------------------------------------
+ ** Headers.
+ ** ----------------------------------------------------------*/
+
+#include "libguile.h"
+#include <stdio.h>
+
+void libtest_subsmob_init (void);
+
+SCM subsmob_make_my_integer (SCM s_integer);
+SCM subsmob_make_my_double  (SCM s_double);
+SCM subsmob_make_my_wrapper (SCM smob);
+
+/* ------------------------------------------------------------ */
+
+#define MY_INTEGER_DATA(SMOB)	((my_integer_client_data_t *)SCM_SMOB_DATA(SMOB))
+#define MY_DOUBLE_DATA(SMOB)	((my_double_client_data_t  *)SCM_SMOB_DATA(SMOB))
+#define MY_WRAPPER_DATA(SMOB)	((my_wrapper_client_data_t *)SCM_SMOB_DATA(SMOB))
+
+/* ------------------------------------------------------------ */
+
+\f
+/** ------------------------------------------------------------
+ ** SMOB driver: my integer.
+ ** ----------------------------------------------------------*/
+
+typedef struct my_integer_client_data_t {
+  int	n;
+} my_integer_client_data_t;
+
+static size_t	my_integer_free		(SCM smob);
+static SCM	my_integer_equalp	(SCM smob_a, SCM smob_b);
+static int	my_integer_print	(SCM smob, SCM s_port, scm_print_state * pstate SCM_UNUSED);
+
+/* Here we use all the custom functions but mark. */
+static scm_t_sub_smob_descriptor my_integer_driver = {
+  .name			= "my-integer",
+  .client_data_size	= 0,
+  .free			= my_integer_free,
+  .equalp		= my_integer_equalp,
+  .mark			= NULL,
+  .print		= my_integer_print,
+  .class		= SCM_BOOL_F,
+  .list_of_supers	= SCM_EOL
+};
+
+/* ------------------------------------------------------------ */
+
+size_t
+my_integer_free (SCM smob)
+{
+  my_integer_client_data_t *	data = MY_INTEGER_DATA(smob);
+
+  scm_gc_free(data, sizeof(my_integer_client_data_t), my_integer_driver.name);
+  return 0;
+}
+SCM
+my_integer_equalp (SCM smob_a, SCM smob_b)
+{
+  int	a = MY_INTEGER_DATA(smob_a)->n;
+  int	b = MY_INTEGER_DATA(smob_b)->n;
+
+  return scm_from_bool(a == b);
+}
+static int
+my_integer_print (SCM smob, SCM s_port, scm_print_state * pstate SCM_UNUSED)
+{
+  scm_puts("#<", s_port);
+  scm_puts(my_integer_driver.name, s_port);
+  scm_puts(" - ", s_port);
+  scm_display(scm_from_int(MY_INTEGER_DATA(smob)->n), s_port);
+  scm_putc('>', s_port);
+  return 1;
+}
+
+/* ------------------------------------------------------------ */
+
+\f
+/** ------------------------------------------------------------
+ ** SMOB driver: my double.
+ ** ----------------------------------------------------------*/
+
+typedef struct my_double_client_data_t {
+  double	n;
+} my_double_client_data_t;
+
+/* Here we use all the default functions. */
+static scm_t_sub_smob_descriptor my_double_driver = {
+  .name			= "my-double",
+  .client_data_size	= sizeof(my_double_client_data_t),
+  .free			= NULL,
+  .equalp		= NULL,
+  .mark			= NULL,
+  .print		= NULL,
+  .class		= SCM_BOOL_F,
+  .list_of_supers	= SCM_EOL
+};
+
+/* ------------------------------------------------------------ */
+
+\f
+/** ------------------------------------------------------------
+ ** SMOB driver: wrapper.
+ ** ----------------------------------------------------------*/
+
+typedef struct my_wrapper_client_data_t {
+  SCM	wrapped;
+} my_wrapper_client_data_t;
+
+static size_t	my_wrapper_free		(SCM smob);
+static SCM	my_wrapper_equalp	(SCM smob_a, SCM smob_b);
+static SCM	my_wrapper_mark		(SCM smob);
+static int	my_wrapper_print	(SCM smob, SCM s_port, scm_print_state * pstate SCM_UNUSED);
+
+/* Here we use mark function, too. */
+static scm_t_sub_smob_descriptor my_wrapper_driver = {
+  .name			= "my-wrapper",
+  .client_data_size	= 0,
+  .free			= my_wrapper_free,
+  .equalp		= my_wrapper_equalp,
+  .mark			= my_wrapper_mark,
+  .print		= my_wrapper_print,
+  .class		= SCM_BOOL_F,
+  .list_of_supers	= SCM_EOL
+};
+
+/* ------------------------------------------------------------ */
+
+size_t
+my_wrapper_free (SCM smob)
+{
+  my_wrapper_client_data_t *	data = MY_WRAPPER_DATA(smob);
+
+  scm_gc_free(data, sizeof(my_wrapper_client_data_t), my_wrapper_driver.name);
+  return 0;
+}
+SCM
+my_wrapper_equalp (SCM smob_a, SCM smob_b)
+{
+  SCM	a = MY_WRAPPER_DATA(smob_a)->wrapped;
+  SCM	b = MY_WRAPPER_DATA(smob_b)->wrapped;
+
+  return scm_eq_p(a, b);
+}
+SCM
+my_wrapper_mark (SCM smob)
+{
+  SCM	x = MY_WRAPPER_DATA(smob)->wrapped;
+
+  scm_gc_mark(x);
+  return SCM_BOOL_T;
+}
+int
+my_wrapper_print (SCM smob, SCM s_port, scm_print_state * pstate SCM_UNUSED)
+{
+  scm_puts("#<", s_port);
+  scm_puts(my_wrapper_driver.name, s_port);
+  scm_puts(" - ", s_port);
+  scm_display(MY_WRAPPER_DATA(smob)->wrapped, s_port);
+  scm_putc('>', s_port);
+  return 1;
+}
+
+/* ------------------------------------------------------------ */
+
+\f
+/** ------------------------------------------------------------
+ ** SMOB makers.
+ ** ----------------------------------------------------------*/
+
+SCM_DEFINE(subsmob_make_my_integer, "make-my-integer",
+	   1, 0, 0, (SCM s_integer), "")
+{
+  my_integer_client_data_t *	data;
+
+  data = scm_gc_malloc(sizeof(my_integer_client_data_t), my_integer_driver.name);
+  data->n = scm_to_int(s_integer);
+  SCM_RETURN_NEWSUBSMOB(&my_integer_driver, data);
+}
+SCM_DEFINE(subsmob_make_my_double, "make-my-double",
+	   1, 0, 0, (SCM s_double), "")
+{
+  my_double_client_data_t *	data;
+
+  data = scm_gc_malloc(sizeof(my_double_client_data_t), my_double_driver.name);
+  data->n = scm_to_double(s_double);
+  SCM_RETURN_NEWSUBSMOB(&my_double_driver, data);
+}
+SCM_DEFINE(subsmob_make_my_wrapper, "make-my-wrapper",
+	   1, 0, 0, (SCM smob), "")
+{
+  my_wrapper_client_data_t *	data;
+
+  data = scm_gc_malloc(sizeof(my_wrapper_client_data_t), my_wrapper_driver.name);
+  data->wrapped = smob;
+  SCM_RETURN_NEWSUBSMOB(&my_wrapper_driver, data);
+}
+
+/* ------------------------------------------------------------ */
+
+\f
+/** ------------------------------------------------------------
+ ** Library initialisation.
+ ** ----------------------------------------------------------*/
+
+void
+libtest_subsmob_init (void)
+{
+  SCM	s_number_class;
+
+
+  s_number_class = scm_variable_ref(scm_c_lookup("<number>"));
+  my_integer_driver.list_of_supers = scm_permanent_object(scm_list_1(s_number_class));
+  my_double_driver.list_of_supers  = scm_permanent_object(scm_list_1(s_number_class));
+  /* The wrapper smob has no supers. */
+
+  scm_make_sub_smob_type(&my_integer_driver);
+  scm_make_sub_smob_type(&my_double_driver);
+  scm_make_sub_smob_type(&my_wrapper_driver);
+  
+  scm_c_define(my_integer_driver.name, my_integer_driver.class);
+  scm_c_define(my_double_driver.name,  my_double_driver.class);
+  scm_c_define(my_wrapper_driver.name, my_wrapper_driver.class);
+
+#ifndef SCM_MAGIC_SNARFER
+# include "test-subsmob-lib.x"
+#endif
+}
+
+/* end of file */

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

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

^ permalink raw reply	[flat|nested] 12+ messages in thread

end of thread, other threads:[~2007-12-15 16:26 UTC | newest]

Thread overview: 12+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
     [not found] <cmu-lmtpd-16123-1197565565-2@mail-imap2.uio.no>
2007-12-15 16:26 ` [patch] subordinate SMOBs with GOOPS superclasses Kjetil S. Matheussen
2007-11-27  6:57 Marco Maggi
2007-12-05 22:19 ` Andy Wingo
2007-12-09 17:33   ` Ludovic Courtès
2007-12-09 18:39     ` Andreas Rottmann
2007-12-11 15:02       ` Ludovic Courtès
2007-12-11 16:36         ` Klaus Schilling
2007-12-12 19:24         ` Neil Jerram
2007-12-12 20:38           ` Clinton Ebadi
2007-12-12 21:41             ` Klaus Schilling
2007-12-13 12:20             ` Ludovic Courtès
2007-12-13 12:14           ` Ludovic Courtès

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).