[cairo-commit] cairo-ocaml/src ml_cairo_wrappers.h, 1.4, 1.5 ml_cairo_wrappers.c, NONE, 1.1 ml_cairo_status.h, 1.1.1.1, 1.2 ml_cairo_status.c, 1.1.1.1, 1.2 ml_cairo.h, 1.3, 1.4 ml_cairo.c, 1.11, 1.12 cairo.mli, 1.9, 1.10 cairo.ml, 1.8, 1.9 Makefile, 1.5, 1.6

[Olivier Andrieu]

Committed by: oandrieu

Update of /cvs/cairo/cairo-ocaml/src
In directory gabe:/tmp/cvs-serv3250/src

Modified Files:
	ml_cairo_wrappers.h ml_cairo_status.h ml_cairo_status.c 
	ml_cairo.h ml_cairo.c cairo.mli cairo.ml Makefile 
Added Files:
	ml_cairo_wrappers.c 
Log Message:
* 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.


Index: ml_cairo_wrappers.h
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/ml_cairo_wrappers.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- ml_cairo_wrappers.h	18 Jun 2004 13:50:29 -0000	1.4
+++ ml_cairo_wrappers.h	18 Oct 2004 00:27:34 -0000	1.5
@@ -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); \

--- NEW FILE: ml_cairo_wrappers.c ---
#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;
}

Index: ml_cairo_status.h
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/ml_cairo_status.h,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- ml_cairo_status.h	18 Nov 2003 19:02:25 -0000	1.1.1.1
+++ ml_cairo_status.h	18 Oct 2004 00:27:34 -0000	1.2
@@ -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)

Index: ml_cairo_status.c
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/ml_cairo_status.c,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- ml_cairo_status.c	18 Nov 2003 19:02:25 -0000	1.1.1.1
+++ ml_cairo_status.c	18 Oct 2004 00:27:34 -0000	1.2
@@ -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 @@
   }
   
   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");
+    }
 
-  if (cairo_exn)
-    raise_with_arg(*cairo_exn, Val_int(status));
-  else
-    failwith("cairo exception");
+  raise_with_arg (*cairo_exn, Val_int(status));
+}
+
+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);
+    }
 }

Index: ml_cairo.h
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/ml_cairo.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- ml_cairo.h	22 Feb 2004 22:41:26 -0000	1.3
+++ ml_cairo.h	18 Oct 2004 00:27:34 -0000	1.4
@@ -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)

Index: ml_cairo.c
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/ml_cairo.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- ml_cairo.c	18 Jun 2004 13:50:29 -0000	1.11
+++ ml_cairo.c	18 Oct 2004 00:27:34 -0000	1.12
@@ -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_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 @@
   _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)
 {

Index: cairo.mli
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/cairo.mli,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- cairo.mli	18 Jun 2004 13:50:29 -0000	1.9
+++ cairo.mli	18 Oct 2004 00:27:34 -0000	1.10
@@ -36,6 +36,16 @@
 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 @@
   | 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 @@
    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

Index: cairo.ml
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/cairo.ml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- cairo.ml	15 Apr 2004 23:59:37 -0000	1.8
+++ cairo.ml	18 Oct 2004 00:27:34 -0000	1.9
@@ -35,6 +35,10 @@
 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 @@
   | 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"

Index: Makefile
===================================================================
RCS file: /cvs/cairo/cairo-ocaml/src/Makefile,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- Makefile	24 Mar 2004 10:39:24 -0000	1.5
+++ Makefile	18 Oct 2004 00:27:34 -0000	1.6
@@ -23,6 +23,7 @@
 
 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