Renames; Comparison + hash support; Exceptions

* src/cairo.ml, src/cairo.mli: s/ct/cr/

* src/ml_cairo_wrappers.[ch]: add comparsion and hash function for
  custom values.

* src/cairo.{ml,mli}, src/ml_cairo.[ch], src/ml_cairo_status.[ch]:
  allow suspending raise of exception on error.

10 files changed, 138 insertions, 34 deletions

diff --git a/ChangeLog b/ChangeLog
index b68fbe3..cb455bc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2004-10-18  Olivier Andrieu  <oliv__a@users.sourceforge.net>
+
+	* src/cairo.ml, src/cairo.mli: s/ct/cr/
+
+	* src/ml_cairo_wrappers.[ch]: add comparsion and hash function for
+	custom values.
+
+	* src/cairo.{ml,mli}, src/ml_cairo.[ch], src/ml_cairo_status.[ch]:
+	allow suspending raise of exception on error.
+
 2004-07-06  Olivier Andrieu  <oliv__a@users.sourceforge.net>
 
 	* src/cairo_gtkcairo.ml, src/cairo_gtkcairo.mli: the signal is now
diff --git a/src/Makefile b/src/Makefile
index fdd46de..1c20cb6 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -23,6 +23,7 @@ gtkcairo.opt : gtkcairo.cmxa dllmlgtkcairo.so
 
 cairo_SRC = cairo_channel.mli cairo.mli cairo.ml \
             cairo_bigarray.mli cairo_bigarray.ml \
+            ml_cairo_wrappers.c \
 	    ml_cairo_status.c ml_cairo_channel.c \
             ml_cairo.c ml_cairo_bigarr.c ml_cairo_path.c
 
diff --git a/src/cairo.ml b/src/cairo.ml
index 4076e31..bc56f7a 100644
--- a/src/cairo.ml
+++ b/src/cairo.ml
@@ -35,6 +35,10 @@ external set_target_ps :
 external set_target_png :
   cr:t -> file:Cairo_channel.t -> format -> width:float -> height:float -> unit = "ml_cairo_set_target_png"
 
+external suspend_exn : t -> unit = "ml_cairo_suspend_exn"
+external resume_exn  : t -> unit = "ml_cairo_resume_exn"
+external get_suspend_exn : t -> bool = "ml_cairo_get_suspend_exn"
+
 type operator =
     OPERATOR_CLEAR
   | OPERATOR_SRC
@@ -158,18 +162,18 @@ type font_slant =
   | FONT_SLANT_ITALIC
   | FONT_SLANT_OBLIQUE
 external select_font :
-  ct:t -> family:string -> slant:font_slant -> weight:font_weight ->
+  cr:t -> family:string -> slant:font_slant -> weight:font_weight ->
     unit = "ml_cairo_select_font"
 external scale_font : cr:t -> scale:float -> unit = "ml_cairo_scale_font"
 external transform_font :
   cr:t -> matrix:matrix -> unit = "ml_cairo_transform_font"
-external show_text : ct:t -> utf8:string -> unit = "ml_cairo_show_text"
+external show_text : cr:t -> utf8:string -> unit = "ml_cairo_show_text"
 external show_glyphs :
-  ct:t -> glyph array -> unit = "ml_cairo_show_glyphs"
-external current_font : ct:t -> font = "ml_cairo_current_font"
+  cr:t -> glyph array -> unit = "ml_cairo_show_glyphs"
+external current_font : cr:t -> font = "ml_cairo_current_font"
 external current_font_extents :
-  ct:t -> font_extents = "ml_cairo_current_font_extents"
-external set_font : ct:t -> font:font -> unit = "ml_cairo_set_font"
+  cr:t -> font_extents = "ml_cairo_current_font_extents"
+external set_font : cr:t -> font:font -> unit = "ml_cairo_set_font"
 external text_extents : t -> utf8:string -> text_extents = "ml_cairo_text_extents"
 external glyph_extents : t -> glyph array -> text_extents = "ml_cairo_glyph_extents"
 external text_path : t -> utf8:string -> unit = "ml_cairo_text_path"
diff --git a/src/cairo.mli b/src/cairo.mli
index ed57956..a7d2d22 100644
--- a/src/cairo.mli
+++ b/src/cairo.mli
@@ -36,6 +36,16 @@ external save    : cr:t -> unit = "ml_cairo_save"
 external restore : cr:t -> unit = "ml_cairo_restore"
 external copy    : dest:t -> src:t -> unit = "ml_cairo_copy"
 
+external suspend_exn : t -> unit = "ml_cairo_suspend_exn"
+(** The functions operating on cairo values normally raise an [Error] exception 
+    immediately if the operation fails. Calling [suspend_exn] will prevent this 
+    automatic exception-raising. *)
+external resume_exn  : t -> unit = "ml_cairo_resume_exn"
+(** Switch back to exception-raising mode. If the cairo object has an error status, 
+    an exception is raised right away. *)
+external get_suspend_exn : t -> bool = "ml_cairo_get_suspend_exn"
+(** Check the current exception-raising mode. *)
+
 (** {4 Target functions} *)
 
 external set_target_surface : cr:t -> surface:surface -> unit = "ml_cairo_set_target_surface"
@@ -207,16 +217,16 @@ type font_slant =
   | FONT_SLANT_OBLIQUE
 
 external select_font :
-  ct:t -> family:string -> slant:font_slant -> weight:font_weight -> unit
+  cr:t -> family:string -> slant:font_slant -> weight:font_weight -> unit
   = "ml_cairo_select_font"
 external scale_font : cr:t -> scale:float -> unit = "ml_cairo_scale_font"
 external transform_font : cr:t -> matrix:matrix -> unit
   = "ml_cairo_transform_font"
-external show_text : ct:t -> utf8:string -> unit = "ml_cairo_show_text"
-external show_glyphs : ct:t -> glyph array -> unit
+external show_text : cr:t -> utf8:string -> unit = "ml_cairo_show_text"
+external show_glyphs : cr:t -> glyph array -> unit
   = "ml_cairo_show_glyphs"
-external current_font : ct:t -> font = "ml_cairo_current_font"
-external current_font_extents : ct:t -> font_extents
+external current_font : cr:t -> font = "ml_cairo_current_font"
+external current_font_extents : cr:t -> font_extents
   = "ml_cairo_current_font_extents"
 external text_extents : t -> utf8:string -> text_extents = "ml_cairo_text_extents"
 external glyph_extents : t -> glyph array -> text_extents = "ml_cairo_glyph_extents"
@@ -350,7 +360,7 @@ external matrix_transform_point : matrix:matrix -> point -> unit
    Mostly unusable ATM. It needs other libraries (freetype2/fontconfig). 
 *)
 
-external set_font : ct:t -> font:font -> unit = "ml_cairo_set_font"
+external set_font : cr:t -> font:font -> unit = "ml_cairo_set_font"
 external font_set_transform : font:font -> matrix:matrix -> unit
   = "ml_cairo_font_set_transform"
 external font_current_transform : font:font -> matrix:matrix -> unit
diff --git a/src/ml_cairo.c b/src/ml_cairo.c
index 995de60..80c02e1 100644
--- a/src/ml_cairo.c
+++ b/src/ml_cairo.c
@@ -11,7 +11,30 @@
 #include "ml_cairo_status.h"
 #include "ml_cairo.h"
 
-Make_Val_final_pointer(cairo_t, Ignore, cairo_destroy, 20)
+static void 
+ml_final_cairo_t (value val)
+{ 
+  cairo_t *cr = cairo_t_val(val);
+  if (cr != NULL) cairo_destroy (cr);
+}
+
+static struct custom_operations ml_custom_cairo_t =
+{ 
+  "cairo_t/001", ml_final_cairo_t, ml_pointer_compare,
+  ml_pointer_hash, custom_serialize_default, custom_deserialize_default 
+};
+
+value Val_cairo_t (cairo_t *p)
+{ 
+  value ret; 
+  struct ml_cairo *ml_c;
+  if (p == NULL) report_null_pointer;
+  ret = alloc_custom (&ml_custom_cairo_t, sizeof (struct ml_cairo), 20, 1000);
+  ml_c = Data_custom_val(ret);
+  ml_c->cr = p;
+  ml_c->suspend_exn = 0;
+  return ret;
+}
 
 Make_Val_final_pointer(cairo_surface_t, Ignore, cairo_surface_destroy, 20)
 #define cairo_surface_t_val(v) ((cairo_surface_t *)Pointer_val(v))
@@ -22,6 +45,30 @@ Make_Val_final_pointer(cairo_matrix_t, Ignore, cairo_matrix_destroy, 100)
 Make_Val_final_pointer(cairo_pattern_t, Ignore, cairo_pattern_destroy, 20)
 #define cairo_pattern_t_val(v) ((cairo_pattern_t *)Pointer_val(v))
 
+CAMLprim value
+ml_cairo_suspend_exn (value v_cr)
+{
+  struct ml_cairo *ml_c = Data_custom_val(v_cr);
+  ml_c->suspend_exn = 1;
+  return Val_unit;
+}
+
+CAMLprim value
+ml_cairo_resume_exn (value v_cr)
+{
+  struct ml_cairo *ml_c = Data_custom_val(v_cr);
+  ml_c->suspend_exn = 0;
+  cairo_treat_status (cairo_status (ml_c->cr));
+  return Val_unit;
+}
+
+CAMLprim value
+ml_cairo_get_suspend_exn (value v_cr)
+{
+  struct ml_cairo *ml_c = Data_custom_val(v_cr);
+  return Val_bool(ml_c->suspend_exn);
+}
+
 ML_0(cairo_create, Val_cairo_t)
 ML_1(cairo_destroy, cairo_t_val, Unit)
 
@@ -639,16 +686,6 @@ cairo_glyph_t_val(cairo_glyph_t * _s, value _v)
   _s->y = Double_val(Field(_v, 2));
 }
 
-static void
-cairo_font_extents_t_val(cairo_font_extents_t * _s, value _v)
-{
-  _s->ascent = Double_field(_v, 0);
-  _s->descent = Double_field(_v, 1);
-  _s->height = Double_field(_v, 2);
-  _s->max_x_advance = Double_field(_v, 3);
-  _s->max_y_advance = Double_field(_v, 4);
-}
-
 static value
 Val_cairo_font_extents_t(cairo_font_extents_t * _s)
 {
diff --git a/src/ml_cairo.h b/src/ml_cairo.h
index 5f99817..158ed7d 100644
--- a/src/ml_cairo.h
+++ b/src/ml_cairo.h
@@ -1,4 +1,8 @@
-#define cairo_t_val(v) ((cairo_t *)Pointer_val(v))
+struct ml_cairo {
+  cairo_t *cr;
+  int suspend_exn;
+};
+#define cairo_t_val(v) (((struct ml_cairo *) Data_custom_val(v))->cr)
 
 static inline cairo_format_t
 cairo_format_t_val(value _v)
diff --git a/src/ml_cairo_status.c b/src/ml_cairo_status.c
index 0bc41d4..16ae210 100644
--- a/src/ml_cairo_status.c
+++ b/src/ml_cairo_status.c
@@ -2,10 +2,13 @@
 #include <caml/callback.h>
 #include <caml/fail.h>
 
+#include "ml_cairo.h"
+#include "ml_cairo_status.h"
+
 void
 cairo_treat_status(cairo_status_t s)
 {
-  static value *cairo_exn = NULL;
+  static value *cairo_exn;
   int status;
 
   switch (s) {
@@ -28,10 +31,24 @@ cairo_treat_status(cairo_status_t s)
   }
   
   if (cairo_exn == NULL)
-    cairo_exn = caml_named_value("cairo_status_exn");
+    {
+      cairo_exn = caml_named_value("cairo_status_exn");
+      if (cairo_exn == NULL)
+	failwith("cairo exception");
+    }
+
+  raise_with_arg (*cairo_exn, Val_int(status));
+}
 
-  if (cairo_exn)
-    raise_with_arg(*cairo_exn, Val_int(status));
-  else
-    failwith("cairo exception");
+void
+check_cairo_status (value cr)
+{
+  struct ml_cairo *ml_c = Data_custom_val(cr);
+  if (! ml_c->suspend_exn) 
+    {
+      cairo_status_t status;
+      status = cairo_status (ml_c->cr);
+      if (status != CAIRO_STATUS_SUCCESS)
+	cairo_treat_status (status);
+    }
 }
diff --git a/src/ml_cairo_status.h b/src/ml_cairo_status.h
index de0ae76..70e4edb 100644
--- a/src/ml_cairo_status.h
+++ b/src/ml_cairo_status.h
@@ -1,5 +1,5 @@
-void  cairo_treat_status(cairo_status_t);
+void cairo_treat_status (cairo_status_t);
+void check_cairo_status (value cr);
 
 #define Val_cairo_status_t(s)  (cairo_treat_status(s), Val_unit)
-#define check_cairo_status(cr) cairo_treat_status(cairo_status(cairo_t_val(cr)))
 #define report_null_pointer    cairo_treat_status(CAIRO_STATUS_NULL_POINTER)
diff --git a/src/ml_cairo_wrappers.c b/src/ml_cairo_wrappers.c
new file mode 100644
index 0000000..0eaa7ec
--- /dev/null
+++ b/src/ml_cairo_wrappers.c
@@ -0,0 +1,18 @@
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include "ml_cairo_wrappers.h"
+
+int ml_pointer_compare (value a, value b)
+{
+  void *p1 = Pointer_val(a);
+  void *p2 = Pointer_val(b);
+  if (p1 == p2) return 0;
+  else if (p1 < p2) return -1;
+  else return 1;
+}
+
+long ml_pointer_hash (value a)
+{
+  void *p = Pointer_val(a);
+  return (long) p;
+}
diff --git a/src/ml_cairo_wrappers.h b/src/ml_cairo_wrappers.h
index 06d458d..73d6495 100644
--- a/src/ml_cairo_wrappers.h
+++ b/src/ml_cairo_wrappers.h
@@ -1,12 +1,15 @@
 #define Pointer_val(val) ((void*)Field(val,1))
 #define Store_pointer(val, p) (Field(val, 1)=Val_bp(p))
 
+int ml_pointer_compare (value, value);
+long ml_pointer_hash (value);
+
 #define Make_Val_final_pointer(type, init, final, adv) \
 static void ml_final_##type (value val) \
 { if (Field(val,1)) final ((type*)Field(val,1)); } \
 static struct custom_operations ml_custom_##type = \
-{ #type "/001", ml_final_##type, custom_compare_default, \
-  custom_hash_default, custom_serialize_default, custom_deserialize_default };\
+{ #type "/001", ml_final_##type, ml_pointer_compare, \
+  ml_pointer_hash, custom_serialize_default, custom_deserialize_default };\
 value Val_##type (type *p) \
 { value ret; if (!p) report_null_pointer; \
   ret = alloc_custom (&ml_custom_##type, sizeof(value), adv, 1000); \