[r2003-11-26 16:17:15 by szach] catch validation exceptions raising CDuce exceptions

Original author: szach
Date: 2003-11-26 16:17:15+00:00

runtime/eval.ml

@@ -34,7 +34,8 @@ let rec eval env e0 = match e0.Typed.exp_descr with
   | Typed.Abstraction a -> eval_abstraction env a
   | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
   | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
-  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> Xml (eval env e1, eval env e2, eval env e3)
+  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
+      Xml (eval env e1, eval env e2, eval env e3)
   | Typed.Xml (_,_) -> assert false
   | Typed.Cst c -> const c
   | Typed.String (i,j,s,e) -> String_utf8 (i,j,s, eval env e)
@@ -63,16 +64,20 @@ and eval_ref env e t=
 
 and eval_validate env e kind schema_name name = 
   let schema = Typer.get_schema schema_name in
-  let validate =
-    match Schema_common.get_component kind name schema with
-    | Schema_types.Type x -> Schema_validator.validate_type x
-    | Schema_types.Element x -> Schema_validator.validate_element x
-    | Schema_types.Attribute x -> Schema_validator.validate_attribute x
-    | Schema_types.Attribute_group x ->
-        Schema_validator.validate_attribute_group x
-    | Schema_types.Model_group x -> Schema_validator.validate_model_group x
-  in
-  validate (eval env e)
+  try
+    let validate =
+      match Schema_common.get_component kind name schema with
+      | Schema_types.Type x -> Schema_validator.validate_type x schema
+      | Schema_types.Element x -> Schema_validator.validate_element x schema
+      | Schema_types.Attribute x -> Schema_validator.validate_attribute x schema
+      | Schema_types.Attribute_group x ->
+          Schema_validator.validate_attribute_group x schema
+      | Schema_types.Model_group x ->
+          Schema_validator.validate_model_group x schema
+    in
+    validate (eval env e)
+  with Schema_common.XSI_validation_error msg ->
+    failwith' ("Schema validation failure: " ^ msg)
 
 and eval_try env arg brs =
   try eval env arg