[r2003-11-20 11:42:32 by szach] invoke schema validation stubs

Original author: szach
Date: 2003-11-20 11:42:32+00:00

runtime/eval.ml

@@ -48,7 +48,8 @@ let rec eval env e0 = match e0.Typed.exp_descr with
   | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
   | Typed.UnaryOp (op,e) -> !eval_unary_op op (eval env e)
   | Typed.BinaryOp (op,e1,e2) -> !eval_binary_op op (eval env e1) (eval env e2)
-  | Typed.Validate (e, schema, name) -> eval_validate env e schema name
+  | Typed.Validate (e, kind, schema, name) ->
+      eval_validate env e kind schema name
   | Typed.Ref (e,t) -> eval_ref env e t
 
 
@@ -61,8 +62,18 @@ and eval_ref env e t=
       ([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
   Record (Builtin_defs.mk_ref ~get ~set)
 
-and eval_validate env e schema name = 
-  raise (CDuceExn (string_latin1 "validate: not implemented"))
+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)
 
 and eval_try env arg brs =
   try eval env arg
@@ -363,7 +374,7 @@ let rec eval env = function
       let v1 = eval env e1 in
       let v2 = eval env e2 in
       !eval_binary_op op v1 v2
-  | Validate (e, schema, name) -> eval_validate env e schema name
+  | Validate (e, kind, schema, name) -> eval_validate env e kind schema name
   | Ref (e,t) -> eval_ref env e t
 
 and eval_abstraction env slots iface body =
@@ -426,13 +437,9 @@ and eval_ref env e t=
       ([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
   Value.Record (Builtin_defs.mk_ref ~get ~set)
 
-and eval_validate env e schema name = 
-  raise (CDuceExn (string_latin1 "validate: not implemented"))
-(*
-  let validator = Typer.get_schema_validator (schema, name) in
-  Schema_validator.validate ~validator 
-    (Schema_xml.pxp_stream_of_value (eval env e))
-*)
+and eval_validate env e kind schema_name name = 
+  raise (CDuceExn (string_latin1
+    "validate: not implemented for compiled expressions"))
 
 and eval_try env arg brs =
   let saved_frame = !frame and saved_sp = !sp in