Commit e2cc58c4 authored by Pietro Abate's avatar Pietro Abate

[r2003-09-24 23:21:08 by cvscast] Cleaning

Original author: cvscast
Date: 2003-09-24 23:21:10+00:00
parent 100aebe4
......@@ -72,6 +72,7 @@ CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
OBJECTS = \
misc/stats.cmo \
misc/serialize.cmo misc/custom.cmo \
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
misc/pretty.cmo misc/ns.cmo \
......
misc/stats.cmo: misc/q_symbol.cmo misc/stats.cmi
misc/stats.cmx: misc/q_symbol.cmo misc/stats.cmi
misc/serialize.cmo: misc/q_symbol.cmo misc/serialize.cmi
misc/serialize.cmx: misc/q_symbol.cmo misc/serialize.cmi
misc/custom.cmo: misc/q_symbol.cmo misc/serialize.cmi
......
......@@ -34,6 +34,8 @@ let specs =
" suppress normal output (typing, results)";
"--stdin", Arg.Unit (fun () -> src := "" :: !src),
" read CDuce script on standard input";
"--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
"print profiling/debugging information";
"-v", Arg.Unit version,
" print CDuce version";
"--version", Arg.Unit version,
......@@ -165,5 +167,8 @@ let main () =
let () = main ()
let () =
at_exit (fun () -> Stats.dump Format.std_formatter);
main ()
type verbosity = Quiet | Summary | Details
let verbosity = ref Quiet
let set_verbosity = (:=) verbosity
let todo = ref []
let register level f = todo := (level,f) :: !todo
let dump ppf =
List.iter (function
| (level,f) when level <= !verbosity -> f ppf
| _ -> ()) !todo
module Timer = struct
type t = {
name: string;
mutable count : int;
mutable total : float;
mutable last : float;
mutable is_in : bool;
}
let print ppf c =
Format.fprintf ppf "Timer %s@\n Total time: %f@\n Count: %i@\n"
c.name c.total c.count
let create s =
let c = { name = s; count = 0; total = 0.; last = 0.; is_in = false } in
register Summary (fun ppf -> print ppf c);
c
let start c =
assert(not c.is_in);
c.is_in <- true;
c.last <- Unix.gettimeofday();
c.count <- c.count + 1
let stop c =
assert(c.is_in);
c.is_in <- false;
c.total <- c.total +. (Unix.gettimeofday () -. c.last)
end
type verbosity = Quiet | Summary | Details
val set_verbosity: verbosity -> unit
val register: verbosity -> (Format.formatter -> unit) -> unit
val dump: Format.formatter -> unit
module Timer: sig
type t
val create: string -> t
val start: t -> unit
val stop: t -> unit
val print: Format.formatter -> t -> unit
end
......@@ -9,7 +9,7 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of U.t * ppat
| TypeDecl of id * ppat
| SchemaDecl of string * Schema_types.schema (* name, schema *)
| LetDecl of ppat * pexpr
| FunDecl of pexpr
......@@ -82,12 +82,12 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of U.t
| PatVar of id
| SchemaVar of (* type/pattern schema variable *)
schema_item_kind * string * string
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (U.t * ppat) list
| Recurs of ppat * (id * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
| And of ppat * ppat
......
......@@ -92,7 +92,7 @@ EXTEND
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
];
uident: [ [ x = IDENT -> parse_ident x ] ];
uident: [ [ x = IDENT -> ident x ] ];
phrase: [
[ (f,p,e) = let_binding ->
......@@ -192,7 +192,6 @@ EXTEND
typ = [ IDENT | keyword ] ->
exp loc (Validate (e, schema, typ))
| "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> Some (Ident.ident x) | None -> None in
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2]))
......@@ -289,7 +288,7 @@ EXTEND
| s = STRING2 ->
let s = U.mk s in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
| a = IDENT -> exp loc (Var (ident a))
| a = uident -> exp loc (Var a)
| "!"; e = expr ->
exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
| i = INT -> exp loc (Integer (Intervals.V.mk i))
......@@ -333,7 +332,7 @@ EXTEND
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in
let p = mk loc (PatVar f) in
let abst = { fun_name = Some (Ident.ident f); fun_iface = a; fun_body = b } in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in
(true,p,e)
| "let"; p = pat; "="; e = expr -> (false,p,e)
......@@ -366,8 +365,9 @@ EXTEND
fun_decl: [
[ f = OPT uident; "("; (a,b) = fun_decl_after_lparen ->
(f,a,b)
[ f = OPT IDENT; "("; (a,b) = fun_decl_after_lparen ->
let f = match f with Some x -> Some (ident x) | None -> None in
(f,a,b)
]
];
......@@ -399,8 +399,8 @@ EXTEND
| x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "??" -> Alt (Epsilon, x) ]
| [ "("; x = regexp; ")" -> x
| "("; a = IDENT; ":="; c = expr; ")" ->
Elem (mk loc (Constant ((ident a,c))))
| "("; a = uident; ":="; c = expr; ")" ->
Elem (mk loc (Constant ((a,c))))
| IDENT "PCDATA" -> string_regexp
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.V.mk_int (parse_char loc i)
......@@ -413,8 +413,8 @@ EXTEND
let c = Chars.atom c in
Seq (Elem (mknoloc (Internal (Types.char c))), accu))
(seq_of_string s)
Epsilon
| e = pat LEVEL "simple" -> Elem e
Epsilon ]
| [ e = pat LEVEL "simple" -> Elem e
]
];
......
......@@ -22,7 +22,7 @@ let () =
List.iter
(fun (n,t) ->
Typer.register_global_types
[ Ident.U.mk n,
[ Ident.ident (Ident.U.mk n),
Location.mknoloc (Ast.Internal t)])
types
......
......@@ -9,6 +9,11 @@ type fv = IdSet.t
let ident = Id.mk
let to_string id =
U.to_string (Id.value id)
let print ppf id =
Format.fprintf ppf "%s" (to_string id)
module Label = struct
type t = Ns.qname
......
......@@ -68,7 +68,7 @@ let approx t =
let map_tree f seq =
let memo = ref H.empty in
let rec aux t =
(* Printf.eprintf "A"; flush stderr; *)
(* Printf.eprintf "A"; flush stderr; *)
try H.find t !memo
with Not_found ->
let v = V.forward () in
......
This diff is collapsed.
This diff is collapsed.
......@@ -11,9 +11,15 @@ val warning: Location.loc -> string -> unit
val error: Location.loc -> string -> 'a
type tenv
(*
val typ_def: tenv -> (id * Ast.ppat) list -> (id * Types.t)
val typ_expr: tenv -> Ast.ppat -> Types.Node.t
val pat_expr: tenv -> Ast.ppat -> Patterns.node
*)
val get_ns_table : tenv -> Ns.table
val register_global_types : (U.t * Ast.ppat) list -> unit
val register_global_types : (id * Ast.ppat) list -> unit
val register_global_ns : U.t -> Ns.t -> unit
val dump_global_types: Format.formatter -> unit
val dump_global_ns: Format.formatter -> unit
......
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