Commit 36ecdbc1 authored by Pietro Abate's avatar Pietro Abate

[r2002-12-20 23:15:22 by cvscast] Empty log message

Original author: cvscast
Date: 2002-12-20 23:15:23+00:00
parent 3da4032a
......@@ -61,6 +61,15 @@ all.cmxa: $(XOBJECTS)
$(OCAMLOPT) -a -o $@ $(XOBJECTS)
OCAMLDEFUN = /home/frisch/defun/bin/ocamldefun
DEFUN_FILES = $(OBJECTS:%.cmo=%)
build_defun:
for i in $(DEFUN_FILES); do \
$(OCAMLDEFUN) $(DIRS:%=-I defun/%) -p -d defun $$i.mli $$i.ml; \
$(OCAMLDEFUN) $(DIRS:%=-I defun/%) -p -d defun $$i.ml; \
done
memento.html: cduce tests/memento.cd tests/memento.xml
./cduce -quiet tests/memento.cd
......
......@@ -126,6 +126,7 @@ EXTEND
|
[ op = [ LIDENT "flatten"
| LIDENT "load_xml"
| LIDENT "load_html"
| LIDENT "print_xml"
| LIDENT "print"
| LIDENT "raise"
......
......@@ -61,6 +61,7 @@ let rec eval env e0 =
| Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
| Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
| Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
| Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
| Typed.Op ("print_xml", [e]) -> eval_print_xml (eval env e)
| Typed.Op ("print", [e]) -> eval_print (eval env e)
| Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
......@@ -129,7 +130,10 @@ and eval_div x y = match (x,y) with
| _ -> assert false
and eval_load_xml e =
Load_xml.run (get_string e)
Load_xml.load_xml (get_string e)
and eval_load_html e =
Load_xml.load_html (get_string e)
and eval_int_of e =
let s = get_string e in
......
......@@ -19,7 +19,14 @@ let is_ws s =
let string s q =
String (0,String.length s,s,q)
let run s =
let attrib att =
let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
SortedMap.from_list (fun _ _ -> assert false) att
let elem tag att child =
Xml (Atom (Types.AtomPool.mk tag), Pair (Record (attrib att), child))
let load_xml_aux s =
let config = { default_config with
store_element_positions = false;
drop_ignorable_whitespace = true
......@@ -39,14 +46,7 @@ let run s =
let txt = Buffer.create 1024 in
let rec parse_elt name att =
let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
let att = SortedMap.from_list (fun _ _ -> assert false) att in
let child = parse_seq () in
let elt = Xml
(Atom (Types.AtomPool.mk name),
Pair (Record att, child)
) in
let elt = elem name att (parse_seq ()) in
(match !curr with
| E_end_tag (_,_) -> get ()
| _ -> failwith "Expect end_tag");
......@@ -84,10 +84,30 @@ let run s =
parse_doc ()
let run s =
let load_xml s =
Location.protect_op "load_xml";
try run s
try load_xml_aux s
with exn ->
raise
(Location.Generic (Pxp_types.string_of_exn exn))
let load_html s =
let rec val_of_doc q = function
| Nethtml.Data data ->
if (is_ws data) then q else string data q
| Nethtml.Element (tag, att, child) ->
Pair (elem tag att (val_of_docs child), q)
and val_of_docs = function
| [] -> nil
| h::t -> val_of_doc (val_of_docs t) h
in
Location.protect_op "load_xml";
let ic = open_in s in
let doc = Nethtml.parse_document
~dtd:Nethtml.relaxed_html40_dtd
(Lexing.from_channel ic) in
let doc = Nethtml.decode ~subst:(fun _ -> "???") doc in
close_in ic;
val_of_docs doc
val run: string -> Value.t
val load_xml: string -> Value.t
val load_html: string -> Value.t
......@@ -293,8 +293,6 @@ let cache_false = ref Assumptions.empty
exception NotEmpty
let nb_rec = ref 0 and nb_norec = ref 0
let rec empty_rec d =
if Assumptions.mem d !cache_false then false
else if Assumptions.mem d !memo then true
......@@ -303,9 +301,7 @@ let rec empty_rec d =
else if not (Chars.is_empty d.chars) then false
else (
let backup = !memo in
if is_recurs_descr d then
(incr nb_rec; memo := Assumptions.add d backup)
else incr nb_norec;
memo := Assumptions.add d backup;
if
(empty_rec_times d.times) &&
(empty_rec_times d.xml) &&
......@@ -1001,7 +997,7 @@ struct
let restrict_label_absent t l =
Boolean.compute_bool
(fun (o,r) as x ->
(fun ((o,r) as x) ->
try
let (lo,_) = List.assoc l r in
if lo then atom (o,SortedMap.diff r [l])
......@@ -1014,7 +1010,7 @@ struct
(* Is it correct ? Do we need to keep track of "first component"
(value of l) as in label_present, then filter at the end ... ? *)
Boolean.compute_bool
(fun (o,r) as x ->
(fun ((o,r) as x) ->
try
let (lo,lt) = List.assoc l r in
if (not lo) && (is_empty (cap d (descr lt))) then Boolean.empty
......@@ -1029,7 +1025,7 @@ struct
let label_present (t:t) l : (descr * t) list =
let x =
Boolean.compute_bool
(fun (o,r) as x ->
(fun ((o,r) as x) ->
try
let (_,lt) = List.assoc l r in
Boolean.atom (descr lt, atom (o, SortedMap.diff r [l]))
......@@ -1042,7 +1038,7 @@ struct
let restrict_label_present t l =
Boolean.compute_bool
(fun (o,r) as x ->
(fun ((o,r) as x) ->
try
Boolean.atom (o, SortedMap.change_exists l (fun (_,lt) -> (false,lt)) r)
with Not_found ->
......@@ -1440,8 +1436,9 @@ module Char = struct
end
let print_stat ppf =
Format.fprintf ppf "nb_rec = %i@." !nb_rec;
(* Format.fprintf ppf "nb_rec = %i@." !nb_rec;
Format.fprintf ppf "nb_norec = %i@." !nb_norec;
*)
()
(*
......
......@@ -874,6 +874,10 @@ and type_op loc op args =
check loc1 t1 Sequence.string
"The argument of load_xml must be a string (filename)";
Types.any
| "load_html", [loc1,t1] ->
check loc1 t1 Sequence.string
"The argument of load_html must be a string (filename)";
Types.any
| "raise", [loc1,t1] ->
Types.empty
| "print_xml", [loc1,t1] ->
......
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