Skip to content

GitLab

Commit 95def5d2 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-23 01:17:28 by afrisch] Print 

Original author: afrisch
Date: 2005-02-23 01:17:29+00:00
parent 2cc25dba
Hide whitespace changes
Inline Side-by-side
compile/compile.ml
View file @ 95def5d2
......@@ -242,7 +242,6 @@ let namespace (tenv,cenv,codes) pr ns =
(tenv,cenv,codes)
let schema (tenv,cenv,codes) x sch =
ignore (Typer.get_schema sch); (* To raise the error here ... *)
let tenv = Typer.enter_schema x sch tenv in
(tenv,cenv,codes)
......
driver/cduce.ml
View file @ 95def5d2
......@@ -74,7 +74,7 @@ let directive_help ppf =
#dump_value <expr>;; dump an XML-ish representation of the resulting
value of a given expression
#print_schema <name>;;
#print_type <name>;;
#print_type <type>;;
#silent;; turn off outputs from the toplevel
#verbose;; turn on outputs from the toplevel
"
......@@ -240,6 +240,7 @@ let debug ppf tenv cenv = function
) c; *)
Format.fprintf ppf "@."
let flush_ppf ppf = Format.fprintf ppf "@."
let directive ppf tenv cenv = function
......@@ -254,12 +255,9 @@ let directive ppf tenv cenv = function
let sch = Typer.get_schema uri in
Schema_common.print_schema ppf sch;
flush_ppf ppf
| `Print_type name ->
Typer.dump_type ppf tenv name;
flush_ppf ppf
| `Print_schema_type schema_ref ->
Typer.dump_schema_type ppf tenv schema_ref;
flush_ppf ppf
| `Print_type t ->
let t = Typer.typ tenv t in
Format.fprintf ppf "%a@." Types.Print.print_noname (Types.descr t)
| `Reinit_ns ->
Typer.set_ns_table_for_printer tenv
| `Help ->
......
misc/pretty.ml
View file @ 95def5d2
......@@ -228,7 +228,8 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
List.iter elim slots;
let r =
List.fold_left
(fun accu (s,t) -> if s == final then alt accu t else accu)
(fun accu (s,t) ->
if s == final then alt accu t else accu)
empty
initial.outg in
regexp r
......
parser/ast.ml
View file @ 95def5d2
......@@ -32,8 +32,7 @@ and toplevel_directive =
| `Help
| `Dump of pexpr
| `Print_schema of U.t
| `Print_schema_type of Schema_types.component_kind * U.t * U.t
| `Print_type of U.t
| `Print_type of ppat
| `Debug of debug_directive
| `Verbose
| `Silent
......
parser/parser.ml
View file @ 95def5d2
......@@ -138,17 +138,8 @@ EXTEND
| DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
| DIRECTIVE "#print_schema"; name = IDENT ->
[ mk loc (Directive (`Print_schema (U.mk name))) ]
| DIRECTIVE "#print_type"; name = IDENT;
schema_part = OPT [
"#"; typ = [ IDENT | keyword ];
kind = OPT [ "as"; k = schema_kind -> k] ->
(kind, typ)
] ->
(match schema_part with
| None -> [ mk loc (Directive (`Print_type (U.mk name))) ]
| Some (kind, typ) ->
[ mk loc
(Directive (`Print_schema_type (kind, U.mk name, U.mk typ))) ])
| DIRECTIVE "#print_type"; t = pat ->
[ mk loc (Directive (`Print_type t)) ]
| DIRECTIVE "#dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
| DIRECTIVE "#reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
| DIRECTIVE "#help" -> [ mk loc (Directive `Help) ]
......
runtime/eval.ml
View file @ 95def5d2
......@@ -229,8 +229,8 @@ and eval_branches_new env brs arg =
and eval_ref env e t=
Value.mk_ref (Types.descr t) (eval env e)
and eval_validate env e kind schema_name name =
let schema = Typer.get_schema schema_name in
and eval_validate env e kind uri name =
let schema = Typer.get_schema uri in
try
let validate =
match Schema_common.get_component kind name schema with
......
types/types.ml
View file @ 95def5d2
......@@ -1366,10 +1366,23 @@ struct
let register_global (name : U.t) d =
if equal { d with hash = 0; xml = BoolPair.empty } empty then
(let l = (*Product.merge_same_2*) (Product.get ~kind:`XML d) in
match l with
| [(t1,t2)] ->
if DescrPairMap.mem (t1,t2) !named_xml then ()
else
named_xml := DescrPairMap.add (t1,t2) name !named_xml
| _ -> ());
if DescrMap.mem d !named then ()
else named := DescrMap.add d name !named
let unregister_global d =
if equal { d with hash = 0; xml = BoolPair.empty } empty then
(let l = Product.get ~kind:`XML d in
match l with
| [(t1,t2)] -> named_xml := DescrPairMap.add (t1,t2) name !named_xml
| _ -> ());
named := DescrMap.add d name !named
| [(t1,t2)] ->
named_xml := DescrPairMap.remove (t1,t2) !named_xml
| _ -> ());
named := DescrMap.remove d !named
let memo = DescrHash.create 63
let counter = ref 0
......@@ -1417,19 +1430,17 @@ struct
s
with Not_found ->
if d.absent then alloc [Abs (prepare ({d with hash=0; absent=false}))]
else
if worth_complement d then
alloc [Neg (prepare (neg d))]
else
let slot = alloc [] in
else if worth_complement d
then alloc [Neg (prepare (neg d))]
else let slot = alloc [] in
if not (worth_abbrev d) then slot.state <- `Expand;
DescrHash.add memo d slot;
let (seq,not_seq) =
if (subtype { empty with hash = 0; times = d.times } seqs_descr) then
(cap d seqs_descr, diff d seqs_descr)
else
else
(empty, d) in
let add u = slot.def <- u :: slot.def in
if (non_empty seq) then
add (Regexp (decompile seq));
......@@ -1441,16 +1452,16 @@ struct
try
let n = DescrPairMap.find (t1,t2) !named_xml in
add (Name n)
with
Not_found ->
let tag =
match Atoms.print_tag t1.atoms with
| Some a when is_empty { t1 with hash=0; atoms = Atoms.empty } -> `Tag a
| _ -> `Type (prepare t1) in
assert (equal { t2 with hash=0; times = empty.times } empty);
List.iter
(fun (ta,tb) -> add (Xml (tag, prepare ta, prepare tb)))
(Product.get t2)
with Not_found ->
let tag =
match Atoms.print_tag t1.atoms with
| Some a when is_empty { t1 with hash=0; atoms = Atoms.empty } -> `Tag a
| _ -> `Type (prepare t1) in
assert (equal { t2 with hash=0; times = empty.times } empty);
List.iter
(fun (ta,tb) ->
add (Xml (tag, prepare ta, prepare tb)))
(Product.get t2);
)
((*Product.merge_same_2*) (Product.get ~kind:`XML not_seq));
List.iter
......@@ -1459,9 +1470,9 @@ struct
add (Record (r,some,none)))
(Record.get not_seq);
(match Chars.is_char not_seq.chars with
| Some c -> add (Char c)
| None ->
List.iter (fun x -> add (Atomic x)) (Chars.print not_seq.chars));
| Some c -> add (Char c)
| None ->
List.iter (fun x -> add (Atomic x)) (Chars.print not_seq.chars));
List.iter (fun x -> add (Atomic x)) (Intervals.print not_seq.ints);
List.iter (fun x -> add (Atomic x)) (Atoms.print not_seq.atoms);
List.iter (fun x -> add (Atomic x)) (Abstract.print not_seq.abstract);
......@@ -1474,15 +1485,18 @@ struct
if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT"));
slot.def <- List.rev slot.def;
slot
and decompile d =
let r =
Decompile.decompile
(fun t ->
let tr = Product.get t in
let tr = Product.get t in
let tr = Product.clean_normal tr in
let tr = List.map (fun (l,t) -> prepare l, t) tr in
tr, Atoms.contains nil_atom t.atoms)
d
d in
r
let gen = ref 0
......@@ -1532,7 +1546,7 @@ struct
then Format.fprintf ppf "@[(%a)@]" aux def
else aux ppf def
and do_print pri ppf = function
(* | Neg { def = [] } -> Format.fprintf ppf "Any" *)
| Neg { def = [] } -> Format.fprintf ppf "Any"
| Neg t -> Format.fprintf ppf "Any \\ (@[%a@])" (do_print_slot 0) t
| Abs t -> Format.fprintf ppf "?(@[%a@])" (do_print_slot 0) t
| Name n -> Format.fprintf ppf "%a" U.print n
......@@ -1637,8 +1651,8 @@ struct
| { state = `Named n } -> n
| _ -> assert false
let print ppf d =
let t = prepare d in
let print ppf t =
let t = prepare t in
assign_name t;
Format.fprintf ppf "@[@[%a@]" (do_print_slot 0) t;
(match List.rev !to_print with
......@@ -1659,6 +1673,14 @@ struct
to_print := [];
DescrHash.clear memo
let print_noname ppf t =
let old_named = !named in
let old_named_xml = !named_xml in
unregister_global t;
print ppf t;
named := old_named;
named_xml := old_named_xml
let print_node ppf n = print ppf (descr n)
let () = forward_print := print
......
types/types.mli
View file @ 95def5d2
......@@ -279,6 +279,9 @@ sig
val print_const : Format.formatter -> const -> unit
val print: Format.formatter -> t -> unit
val print_node: Format.formatter -> Node.t -> unit
(* Don't try to find a global name at toplevel *)
val print_noname: Format.formatter -> t -> unit
end
typing/typer.ml
View file @ 95def5d2
......@@ -58,6 +58,14 @@ let dump ppf _ = failwith "Typer.dump"
let equal _ _ = failwith "Typer.equal"
let check _ = failwith "Typer.check"
let load_schema_fwd = ref (fun x uri -> assert false)
let enter_schema x uri env =
!load_schema_fwd x uri;
{ env with schemas = UEnv.add x uri env.schemas }
(* TODO: filter out builtin defs ? *)
let serialize_item s = function
| Type t -> Serialize.Put.bits 1 s 0; Types.serialize s t
......@@ -65,7 +73,11 @@ let serialize_item s = function
let serialize s env =
Serialize.Put.env Id.serialize serialize_item Env.iter s env.ids;
Ns.serialize_table s env.ns
Ns.serialize_table s env.ns;
let schs =
UEnv.fold (fun name uri accu -> (name,uri)::accu) env.schemas [] in
Serialize.Put.list (Serialize.Put.pair U.serialize Serialize.Put.string) s schs
let deserialize_item s = match Serialize.Get.bits 1 s with
| 0 -> Type (Types.deserialize s)
......@@ -75,7 +87,12 @@ let deserialize_item s = match Serialize.Get.bits 1 s with
let deserialize s =
let ids = Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in
let ns = Ns.deserialize_table s in
{ ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty }
let schs =
Serialize.Get.list
(Serialize.Get.pair U.deserialize Serialize.Get.string) s in
let env =
{ ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty } in
List.fold_left (fun env (name,uri) -> enter_schema name uri env) env schs
let empty_env = {
......@@ -95,8 +112,6 @@ let find_cu x env =
with Not_found -> Types.CompUnit.mk x
let enter_schema x uri env =
{ env with schemas = UEnv.add x uri env.schemas }
let find_schema x env =
try UEnv.find x env.schemas
with Not_found -> raise (Error (Printf.sprintf "%s: no such schema" (U.get_str x)))
......@@ -219,11 +234,14 @@ let schema_model_groups =
State.ref "Typer.schema_model_groups" (Hashtbl.create 51)
let get_schema_fwd = ref (fun _ -> assert false)
(*
let get_schema uri =
try Hashtbl.find !schemas uri
with Not_found -> assert false
*)
let find_schema_descr_uri kind uri (name : Ns.qname) =
try
ignore (!get_schema_fwd uri);
let elt () = Hashtbl.find !schema_elements (uri, name) in
let typ () = Hashtbl.find !schema_types (uri, name) in
let att () = Hashtbl.find !schema_attributes (uri, name) in
......@@ -853,19 +871,6 @@ let dump_types ppf env =
function
(Type _) -> Format.fprintf ppf " %a" Ident.print v
| _ -> ()) env.ids
let dump_type ppf env name =
try
(match Env.find (Ident.ident name) env.ids with
| Type t -> Types.Print.print ppf t
| _ -> raise Not_found)
with Not_found ->
raise (Error (Printf.sprintf "Type %s not found" (U.get_str name)))
let dump_schema_type ppf env (k, s, n) =
let name = qname env noloc n in
let uri = find_schema s env in
let descr = find_schema_descr_uri k uri name in
Types.Print.print ppf descr
let dump_ns ppf env =
Ns.dump_table ppf env.ns
......@@ -1716,58 +1721,63 @@ let get_schema_names env = UEnv.fold (fun n _ acc -> n :: acc) env.schemas []
open Schema_types
let get_schema uri =
try Hashtbl.find !schemas uri
with Not_found ->
let schema = Schema_parser.schema_of_uri uri in
let log_schema_component kind uri name cd_type =
if not (Schema_builtin.is_builtin name) then begin
Format.fprintf Format.std_formatter
"Registering schema %s: %s # %s"
kind uri (Ns.QName.to_string name);
(* if debug_schema then
Types.Print.print Format.std_formatter cd_type; *)
Format.fprintf Format.std_formatter "@."
end
in
Hashtbl.add !schemas uri schema;
List.iter (* Schema types -> CDuce types *)
(fun type_def ->
let name = Schema_common.name_of_type_definition type_def in
let cd_type = Schema_converter.cd_type_of_type_def ~schema type_def in
log_schema_component "type" uri name cd_type;
Hashtbl.add !schema_types (uri, name) cd_type)
schema.Schema_types.types;
List.iter (* Schema attributes -> CDuce types *)
(fun att_decl ->
let cd_type = Schema_converter.cd_type_of_att_decl ~schema att_decl in
let name = Schema_common.name_of_attribute_declaration att_decl in
log_schema_component "attribute" uri name cd_type;
Hashtbl.add !schema_attributes (uri, name) cd_type)
schema.Schema_types.attributes;
List.iter (* Schema elements -> CDuce types *)
(fun elt_decl ->
let cd_type = Schema_converter.cd_type_of_elt_decl ~schema elt_decl in
let name = Schema_common.name_of_element_declaration elt_decl in
log_schema_component "element" uri name cd_type;
Hashtbl.add !schema_elements (uri, name) cd_type)
schema.Schema_types.elements;
List.iter (* Schema attribute groups -> CDuce types *)
(fun ag ->
let cd_type = Schema_converter.cd_type_of_attr_uses ~schema ag.ag_def
in
log_schema_component "attribute group" uri ag.ag_name cd_type;
Hashtbl.add !schema_attribute_groups (uri, ag.ag_name) cd_type)
schema.Schema_types.attribute_groups;
List.iter (* Schema model groups -> CDuce types *)
(fun mg ->
let cd_type = Schema_converter.cd_type_of_model_group ~schema mg.mg_def in
log_schema_component "model group" uri mg.mg_name cd_type;
Hashtbl.add !schema_model_groups (uri, mg.mg_name) cd_type)
schema.Schema_types.model_groups;
schema
let get_schema uri =
Hashtbl.find !schemas uri
let load_schema schema_name uri =
if Hashtbl.mem !schemas uri then ()
else (
let schema = Schema_parser.schema_of_uri uri in
let log_schema_component kind uri name cd_type =
if not (Schema_builtin.is_builtin name) then begin
let n = U.to_string schema_name ^ "#" ^ (Ns.QName.to_string name) in
Types.Print.register_global (U.mk_latin1 n) cd_type;
Format.fprintf Format.std_formatter "Registering schema %s: %s" kind n;
(* if debug_schema then
Types.Print.print Format.std_formatter cd_type; *)
Format.fprintf Format.std_formatter "@."
end
in
Hashtbl.add !schemas uri schema;
List.iter (* Schema types -> CDuce types *)
(fun type_def ->
let name = Schema_common.name_of_type_definition type_def in
let cd_type = Schema_converter.cd_type_of_type_def ~schema type_def in
log_schema_component "type" uri name cd_type;
Hashtbl.add !schema_types (uri, name) cd_type)
schema.Schema_types.types;
List.iter (* Schema attributes -> CDuce types *)
(fun att_decl ->
let cd_type = Schema_converter.cd_type_of_att_decl ~schema att_decl in
let name = Schema_common.name_of_attribute_declaration att_decl in
log_schema_component "attribute" uri name cd_type;
Hashtbl.add !schema_attributes (uri, name) cd_type)
schema.Schema_types.attributes;
List.iter (* Schema elements -> CDuce types *)
(fun elt_decl ->
let cd_type = Schema_converter.cd_type_of_elt_decl ~schema elt_decl in
let name = Schema_common.name_of_element_declaration elt_decl in
log_schema_component "element" uri name cd_type;
Hashtbl.add !schema_elements (uri, name) cd_type)
schema.Schema_types.elements;
List.iter (* Schema attribute groups -> CDuce types *)
(fun ag ->
let cd_type = Schema_converter.cd_type_of_attr_uses ~schema ag.ag_def
in
log_schema_component "attribute group" uri ag.ag_name cd_type;
Hashtbl.add !schema_attribute_groups (uri, ag.ag_name) cd_type)
schema.Schema_types.attribute_groups;
List.iter (* Schema model groups -> CDuce types *)
(fun mg ->
let cd_type =
Schema_converter.cd_type_of_model_group ~schema mg.mg_def in
log_schema_component "model group" uri mg.mg_name cd_type;
Hashtbl.add !schema_model_groups (uri, mg.mg_name) cd_type)
schema.Schema_types.model_groups;
)
let () = get_schema_fwd := get_schema
let () = load_schema_fwd := load_schema
typing/typer.mli
View file @ 95def5d2
......@@ -44,10 +44,6 @@ val typ: t -> Ast.ppat -> Types.Node.t
val pat: t -> Ast.ppat -> Patterns.node
val dump_types: Format.formatter -> t -> unit
val dump_type: Format.formatter -> t -> U.t -> unit
val dump_schema_type:
Format.formatter -> t -> (Schema_types.component_kind * U.t * U.t) -> unit
val dump_ns: Format.formatter -> t -> unit
val set_ns_table_for_printer: t -> unit
......@@ -69,7 +65,6 @@ val flatten: (Types.t -> bool -> Types.t) -> (Types.t -> bool -> Types.t)
(** {2 Schema stuff} *)
val get_schema: string -> Schema_types.schema (** lookup schema by uri *)
val get_schema_names: t -> U.t list (** registered schema names *)
(* Operators *)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment