[r2002-10-29 18:49:26 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-29 18:49:26+00:00

Makefile

-DEBUG = -g
-OCAMLC = ocamlc
+DEBUG =
+# -g
+PACKAGES = pxp-engine,pxp-lex-iso88591,camlp4,num
+OCAMLC = ocamlfind ocamlc -package $(PACKAGES)
+OCAMLOPT = ocamlfind ocamlopt  -package $(PACKAGES)
 
 PARSER = parser/lexer.cmo parser/location.cmo parser/ast.cmo parser/parser.cmo
 
@@ -29,39 +32,38 @@ INCLUDES = -I +camlp4 -I parser -I types -I runtime -I typing
 SYNTAX_PARSER = -pp 'camlp4o pa_extend.cmo'
 
 all.cma: $(OBJECTS)
-	$(OCAMLC) $(DEBUG) -o all.cma -I +camlp4 gramlib.cma nums.cma -a $(OBJECTS)
+	$(OCAMLC) $(DEBUG) -o all.cma -linkpkg gramlib.cma -a $(OBJECTS)
 
 all.cmxa: $(XOBJECTS)
-	ocamlopt -a -o all.cmxa $(XOBJECTS)
+	$(OCAMLOPT) -a -o all.cmxa $(XOBJECTS)
 
 
-cduce: all.cma $(DRIVER)
-	$(OCAMLC) $(DEBUG) -o cduce all.cma $(DRIVER)
+cduce: $(OBJECTS) $(DRIVER)
+	$(OCAMLC) $(DEBUG) -linkpkg -o cduce gramlib.cma $(OBJECTS) $(DRIVER)
 
 cduce.opt: all.cmxa $(XDRIVER)
-	ocamlopt -o cduce.opt -I +camlp4 gramlib.cmxa nums.cmxa all.cmxa $(XDRIVER)
+	$(OCAMLOPT) -linkpkg -o cduce.opt gramlib.cmxa $(XOBJECTS) $(XDRIVER)
 
 compute_depend:
 	@echo "Computing dependencies ..."
 	ocamldep $(INCLUDES) $(SYNTAX_PARSER) $(DEPEND) > depend
 
 run_top: all.cma
-	ledit ocaml $(INCLUDES) all.cma
+	ledit ocaml $(INCLUDES) `ocamlfind use pxp` all.cma
 
 clean:
-	(cd parser; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
-	(cd types; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
-	(cd typing; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
-	(cd driver; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
-	rm -f *.cmi *.cmo *.cma *.cmx *.o *~
-	rm -f cduce
+	for i in $(DIRS); do \
+	(cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *~); \
+	done
+	rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~
+	rm -f cduce cduce.opt
 
 .SUFFIXES: .ml .mli .cmo .cmi .cmx
 
 .ml.cmo:
 	$(OCAMLC) $(DEBUG) -c $(SYNTAX_PARSER) $(INCLUDES) $<
 .ml.cmx:
-	ocamlopt -c $(SYNTAX_PARSER) $(INCLUDES) $<
+	$(OCAMLOPT) -c $(SYNTAX_PARSER) $(INCLUDES) $<
 
 .mli.cmi:
 	$(OCAMLC) $(DEBUG) -c $(INCLUDES) $<

depend

@@ -61,7 +61,12 @@ types/sortedMap.cmi: types/sortedList.cmi
 types/syntax.cmi: types/patterns.cmi types/types.cmi 
 types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
     types/sortedMap.cmi 
-runtime/value.cmi: types/patterns.cmi typing/typed.cmo 
+runtime/value.cmi: types/chars.cmi types/patterns.cmi types/sortedMap.cmi \
+    typing/typed.cmo types/types.cmi 
+runtime/load_xml.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
+    types/types.cmi runtime/value.cmi 
+runtime/load_xml.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
+    types/types.cmx runtime/value.cmx 
 runtime/value.cmo: types/chars.cmi types/patterns.cmi types/sequence.cmi \
     types/sortedMap.cmi typing/typed.cmo types/types.cmi runtime/value.cmi 
 runtime/value.cmx: types/chars.cmx types/patterns.cmx types/sequence.cmx \

parser/parser.ml

@@ -82,6 +82,7 @@ EXTEND
  
     |
     [ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
+    | LIDENT "load_xml"; e = expr -> mk loc (Op ("load_xml",[e]))
     | e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
     ]
 

runtime/value.ml

@@ -7,7 +7,6 @@ type t =
   | Atom of Types.atom
   | Integer of Big_int.big_int
   | Char of Chars.Unichar.t
-  | String of int * string * t   (* position in string *)
   | Fun of abstr
 and env = t Env.t
 and abstr = { 
@@ -41,7 +40,6 @@ let rec print ppf v =
     | Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
     | Char c ->	Chars.Unichar.print ppf c
     | Fun c -> Format.fprintf ppf "<fun>"
-    | String (i,s,y) -> Format.fprintf ppf "<str:%S;%i>%a" s i print y
 and print_quoted_str ppf = function
   | Pair (Char c, y) -> 
       Chars.Unichar.print_in_string ppf c; 
@@ -76,6 +74,91 @@ and print_field ppf (l,v) =
   Format.fprintf ppf "%s=%a" (Types.label_name l) print v  
 
 
+(* Loading XML documents *)
+
+(*TODO: close the file ! *)
+
+module Load_xml = 
+struct
+
+  open Pxp_yacc
+  open Pxp_lexer_types
+  open Pxp_types
+
+  let run s =
+    let config = { default_config with 
+		     store_element_positions = false;
+		     drop_ignorable_whitespace = true
+		 }
+    in
+    let mgr = create_entity_manager config (from_file s) in
+    let next_event = 
+      create_pull_parser config (`Entry_document[]) mgr in
+    let curr = ref E_end_of_stream in
+    let get () =
+      match next_event () with 
+	| Some x -> curr := x 
+	| None -> () in
+    
+    let string s q =
+      let rec check_ws i = (i < 0) || 
+			   (match s.[i] with
+			      | ' ' | '\t' | '\n' | '\r' -> check_ws (i - 1) 
+			      | _ -> false) in
+      if check_ws (String.length s - 1) then q 
+      else
+	let rec aux i accu =
+	  if i < 0 then accu
+	  else aux (i - 1) (Pair 
+			      (Char (Chars.Unichar.from_char s.[i]), 
+			       accu))
+	in
+	aux (String.length s - 1) q in
+    
+    let nil = Atom Sequence.nil_atom in
+    
+    
+    let rec parse_elt name att =
+      let att = List.map (fun (l,v) -> Types.label l, string v nil) att in
+      let att = SortedMap.from_list (fun _ _ -> assert false) att in
+      let child = parse_seq () in
+      
+      let elt = Pair 
+		  (Atom (Types.mk_atom name),
+		   Pair (Record att, child)
+		  ) in
+      (match !curr with
+	 | E_end_tag (_,_) -> get ()
+	 | _ -> failwith "Expect end_tag");
+      elt
+	
+	
+    and parse_seq () =
+      match !curr with
+	| E_start_tag (name,att,_) -> 
+	    get ();
+	    let e1 = parse_elt name att in
+	    let rest = parse_seq () in
+	    Pair (e1, rest)
+	| E_char_data data ->
+	    get ();
+	    let rest = parse_seq () in
+	    string data rest
+	| E_end_tag (_,_) ->
+	    nil
+	| _ -> failwith "Expect start_tag, char_data, or end_tag"
+	    
+    and parse_doc () =
+      match !curr with
+	| E_start_tag (name,att,_) ->  get (); parse_elt name att
+	| _ -> get (); parse_doc ()
+    in
+    get ();
+    parse_doc ()
+
+end
+
+
 (* Running dispatchers *)
 
 let const = function
@@ -141,8 +224,6 @@ and run_disp_kind actions v = match v with
   | Fun f ->
       run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t) 
         actions.Patterns.Compile.basic
-  | String (i,s,y) ->
-      failwith "Dispatch on string not yet implemented"
 
 and run_disp_basic v f = function
   | [(_,r)] -> make_result_basic v r
@@ -219,6 +300,7 @@ let rec eval env e0 =
     | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
     | 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.Dot (e, l) -> eval_dot l (eval env e)
     | Typed.DebugTyper t -> failwith "Evaluating a ! expression"
     | _ -> failwith "Unknown expression"
@@ -240,7 +322,6 @@ and eval_branches env brs arg =
 
 and eval_map env brs = function
   | Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
-  | String (i,s,y) -> failwith "map on string not implemented"
   | q -> q
   
 and eval_flatten = function
@@ -249,7 +330,6 @@ and eval_flatten = function
 
 and eval_concat l1 l2 = match l1 with
   | Pair (x,y) -> Pair (x, eval_concat y l2)
-  | String (i,s,y) -> String(i,s, eval_concat y l2)
   | q -> l2
 
 and eval_dot l = function
@@ -272,3 +352,14 @@ and eval_div x y = match (x,y) with
   | (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
   | _ -> assert false
 
+and eval_load_xml e =
+  Load_xml.run (get_string e)
+
+and get_string e =
+  let rec compute_len accu = function
+    | Pair (_,y) -> compute_len (accu + 1) y
+    | _ -> accu in
+  let rec fill pos s = function
+    | Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
+    | _ -> s in
+  fill 0 (String.create (compute_len 0 e)) e

runtime/value.mli

-type t
-type env
+type t =
+  | Pair of t * t
+  | Record of (Types.label,t) SortedMap.t
+  | Atom of Types.atom
+  | Integer of Big_int.big_int
+  | Char of Chars.Unichar.t
+  | Fun of abstr
+and abstr
+and env
+
 val empty_env : env
 
 val print: Format.formatter -> t -> unit

types/chars.ml

@@ -13,6 +13,10 @@ module Unichar = struct
 
   let to_int c = c
 
+  let to_char c =
+    if (c > 255) then failwith "to_char: code-point > 255";
+    Char.chr c
+
   let print ppf c =
     if (c < 128) 
     then Format.fprintf ppf "%C" (Char.chr c)

types/chars.mli

@@ -3,6 +3,7 @@ module Unichar : sig
   val from_int: int -> t
   val from_char: char -> t
   val to_int: t -> int
+  val to_char: t -> char
 
   val print : Format.formatter -> t -> unit
   val print_in_string : Format.formatter -> t -> unit

types/sequence.ml

@@ -46,7 +46,7 @@ let any = Types.descr any_node
 let seqseq = Types.descr (star_node any_node)
 
 let star t = Types.descr (star_node (Types.cons t))
-  
+let string = star (Types.Char.any)  
 
 let approx t =
   let memo = H.create 13 in

types/sequence.mli

@@ -2,6 +2,7 @@ val nil_type: Types.descr
 val nil_atom: Types.atom
 val any: Types.descr
 val seqseq: Types.descr
+val string: Types.descr
 
 val concat: Types.descr -> Types.descr -> Types.descr
 val flatten: Types.descr -> Types.descr

types/types.ml

@@ -833,6 +833,7 @@ end
 
 module Char = struct
   let has_char d c = Chars.contains c d.chars
+  let any = { empty with chars = Chars.any }
 end
 
 (*

types/types.mli

@@ -157,6 +157,7 @@ end
 
 module Char : sig
   val has_char : descr -> Chars.Unichar.t -> bool
+  val any : descr
 end
 
 val normalize : descr -> descr

typing/typer.ml

@@ -630,6 +630,10 @@ and type_op loc op args =
 	check loc1 t1 Sequence.seqseq 
 	  "The argument of flatten must be a sequence of sequences";
 	Sequence.flatten t1
+    | "load_xml", [loc1,t1] ->
+	check loc1 t1 Sequence.string
+	  "The argument of load_xml must be a string (filename)";
+	Types.any
     | _ -> assert false
 
 and type_int_binop f loc1 t1 loc2 t2 =