[r2003-05-20 13:58:26 by cvscast] Empty log message

Original author: cvscast
Date: 2003-05-20 13:58:26+00:00

driver/cduce.ml

@@ -114,17 +114,6 @@ let debug ppf = function
       List.iter (fun (x,t) ->
 		   Format.fprintf ppf " %a:%a@\n" U.print (Id.value x)
 		     print_norm (Types.descr t)) f
-  | `Compile2 (t,pl) -> 
-      Format.fprintf ppf "[DEBUG:compile2]@\n";
-(*      let t = Types.descr (Typer.typ t) in
-      let pl = List.map (fun p -> 
-			   let p = Typer.pat p in
-			   let a = Types.descr (Patterns.accept p) in
-			   (Some p, Types.cap a t)) pl in
-      let d = Patterns.Compiler.make_dispatcher t pl in
-      Patterns.Compiler.print_disp ppf d *)
-      ()
-
   | `Accept p ->
       Format.fprintf ppf "[DEBUG:accept]@\n";
       let p = Typer.pat p in
@@ -135,7 +124,6 @@ let debug ppf = function
       let t = Typer.typ t
       and pl = List.map Typer.pat pl in
       Patterns.Compile.debug_compile ppf t pl
-  | `Normal_record p -> assert false
 
 
 

parser/ast.ml

@@ -17,8 +17,6 @@ and debug_directive =
   [ `Filter of ppat * ppat
   | `Accept of ppat
   | `Compile of ppat * ppat list 
-  | `Normal_record of ppat
-  | `Compile2 of ppat * ppat list
   | `Subtype of ppat * ppat
   ]
 

parser/parser.ml

@@ -11,7 +11,10 @@ let gram    = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
 
 let parse_ident = Encodings.Utf8.mk_latin1
 
+let id_dummy = ident (U.mk "$$$")
+let atom s = Atoms.mk (parse_ident s)
 let label s = LabelPool.mk (parse_ident s)
+let ident s = ident (parse_ident s)
 
 let prog    = Grammar.Entry.create gram "prog"
 let expr    = Grammar.Entry.create gram "expression"
@@ -124,8 +127,6 @@ EXTEND
     [ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
     | LIDENT "accept"; p = pat -> `Accept p
     | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
-    | LIDENT "normal_record"; t = pat -> `Normal_record t
-    | LIDENT "compile2"; t = pat; p = LIST1 pat -> `Compile2 (t,p)
     | LIDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
     ]
   ];
@@ -145,10 +146,9 @@ EXTEND
     "top" RIGHTA
     [ "match"; e = SELF; "with"; b = branches -> exp loc (Match (e,b))
     | "try"; e = SELF; "with"; b = branches -> 
-	let id = ident (U.mk "x") in
 	let default = 
-	  mknoloc (Capture id), 
-	  Op ("raise",[Var id]) in
+	  mknoloc (Capture id_dummy), 
+	  Op ("raise",[Var id_dummy]) in
 	exp loc (Try (e,b@[default]))
     | "map"; e = SELF; "with"; b = branches -> exp loc (Map (false,e,b))
     | "xtransform"; e = SELF; "with"; b = branches -> exp loc (Xtrans (e,b))
@@ -189,11 +189,10 @@ EXTEND
 	let tag = mk loc (Internal (Types.atom (Atoms.any))) in
 	let att = mk loc (Internal Types.Record.any) in
 	let any = mk loc (Internal (Types.any)) in
-	let id = ident (U.mk "x") in
-	let re = Star(Alt(SeqCapture(id,Elem p), Elem any)) in
+	let re = Star(Alt(SeqCapture(id_dummy,Elem p), Elem any)) in
 	let ct = mk loc (Regexp (re,any)) in
         let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
-	let b = (p,  Var id) in
+	let b = (p,  Var id_dummy) in
 	exp loc (Op ("flatten", [Map (false,e,[b])]))
     ]
     |
@@ -236,14 +235,13 @@ EXTEND
 	exp loc l
     | "<"; t = [ "("; e = expr; ")" -> e
 	       | a = [ LIDENT | UIDENT | keyword ] -> 
-		   let a = parse_ident a in
-		   exp loc (Cst (Types.Atom (Atoms.mk a))) ];
+		   exp loc (Cst (Types.Atom (atom a))) ];
 	a = expr_attrib_spec; ">"; c = expr ->
 	exp loc (Xml (t, Pair (a,c)))
     | "{"; r = [ expr_record_spec | -> exp loc (RecordLitt LabelMap.empty) ]; "}" -> r
     | s = STRING2 ->
 	exp loc (tuple (char_list loc s @ [cst_nil]))
-    | a = LIDENT -> exp loc (Var (ident (parse_ident a)))
+    | a = LIDENT -> exp loc (Var (ident a))
     ]
 
   ];
@@ -272,7 +270,7 @@ EXTEND
  fun_decl: [
 (* need an hack to do this, because both productions would
    match   [ OPT LIDENT; "("; pat ] .... *)
-   [ f = OPT [ x = LIDENT -> ident (parse_ident x)]; "("; p1 = pat LEVEL "no_arrow";
+   [ f = OPT [ x = LIDENT -> ident x]; "("; p1 = pat LEVEL "no_arrow";
     res = [ "->"; p2 = pat;
 	    a = [ ";"; a = LIST0 arrow SEP ";" -> a | -> [] ];
 	    ")"; b = branches -> `Classic (p2,a,b)
@@ -314,7 +312,7 @@ EXTEND
 	  | _ -> Alt (x,y) 
     ]
   | [ x = regexp; y = regexp -> Seq (x,y) ]
-  | [ a = LIDENT; "::"; x = regexp -> SeqCapture (ident (parse_ident a),x) ]
+  | [ a = LIDENT; "::"; x = regexp -> SeqCapture (ident a,x) ]
   | [ x = regexp; "*" -> Star x
     | x = regexp; "*?" -> WeakStar x
     | x = regexp; "+" -> Seq (x, Star x)
@@ -323,7 +321,7 @@ EXTEND
     | x = regexp; "??" -> Alt (Epsilon, x) ]
   | [ "("; x = regexp; ")" -> x
     | "("; a = LIDENT; ":="; c = const; ")" -> 
-	Elem (mk loc (Constant ((ident (parse_ident a),c))))
+	Elem (mk loc (Constant ((ident a,c))))
     | UIDENT "PCDATA" -> string_regexp
     | i = STRING1; "--"; j = STRING1 ->
 	let i = Chars.mk_int (parse_char loc i)
@@ -356,9 +354,9 @@ EXTEND
       [ "{"; r = record_spec; "}" -> mk loc (Record (true,r))
       | "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
       | LIDENT "_" -> mk loc (Internal Types.any)
-      | a = LIDENT -> mk loc (Capture (ident (parse_ident a)))
+      | a = LIDENT -> mk loc (Capture (ident a))
       | "("; a = LIDENT; ":="; c = const; ")" -> 
-	  mk loc (Constant (ident (parse_ident a),c))
+	  mk loc (Constant (ident a,c))
       | a = UIDENT -> mk loc (PatVar a)
       | i = INT ; "--"; j = INT -> 
           let i =  Intervals.mk i 
@@ -385,7 +383,7 @@ EXTEND
              "]" -> mk loc (Regexp (r,q))
       | "<"; t =
         [ x = [ LIDENT | UIDENT | keyword ] ->
-	    let a = if x = "_" then Atoms.any else Atoms.atom (Atoms.mk (parse_ident x)) in
+	    let a = if x = "_" then Atoms.any else Atoms.atom (atom x) in
 	    mk loc (Internal (Types.atom a))
 	| "("; t = pat; ")" -> t ];
 	a = attrib_spec; ">"; c = pat ->
@@ -423,7 +421,7 @@ EXTEND
   const:
     [ 
       [ i = INT -> Types.Integer (Intervals.mk i)
-      | "`"; a = [LIDENT | UIDENT | keyword ] -> Types.Atom (Atoms.mk (parse_ident a))
+      | "`"; a = [LIDENT | UIDENT | keyword ] -> Types.Atom (atom a)
       | c = char -> Types.Char c ]
     ];
 

runtime/eval.ml

@@ -77,8 +77,8 @@ let rec eval env e0 =
     | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
     | Typed.Op ("load_file", [e]) -> eval_load_file ~utf8:false (eval env e)
     | Typed.Op ("load_file_utf8", [e]) -> eval_load_file ~utf8:true (eval env e)
-    | Typed.Op ("print_xml", [e]) -> eval_print_xml (eval env e)
-    | Typed.Op ("print_xml_utf8", [e]) -> eval_print_xml_utf8 (eval env e)
+    | Typed.Op ("print_xml", [e]) -> Print_xml.print_xml ~utf8:false (eval env e)
+    | Typed.Op ("print_xml_utf8", [e]) -> Print_xml.print_xml ~utf8:true (eval env e)
     | Typed.Op ("print", [e]) -> eval_print (eval env e)
     | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
     | Typed.Op ("atom_of", [e]) -> eval_atom_of (eval env e)
@@ -234,11 +234,6 @@ and eval_atom_of e =
   let (s,_) = get_string_utf8 e in (* TODO: check that s is a correct Name wrt XML *)
   Atom (Atoms.mk s)
   
-and eval_print_xml_utf8 v =
-  string_utf8 (U.mk (Print_xml.string_of_xml ~enc:`Utf8 v))
-and eval_print_xml v =
-  string_latin1 (Print_xml.string_of_xml ~enc:`Latin1 v)
-
 and eval_print v =
   Location.protect_op "print";
   print_string (get_string_latin1 v);

runtime/print_xml.ml

@@ -10,10 +10,8 @@ let exn_print_xml = CDuceExn (Pair (
 				Atom (Atoms.mk_ascii "Invalid_argument"),
 				string_latin1 "print_xml"))
 
-let string_of_xml ~enc v= 
-  let to_enc = match enc with
-    | `Utf8 -> `Enc_utf8
-    | `Latin1 -> `Enc_iso88591 in
+let string_of_xml ~utf8 v= 
+  let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
 
   let buffer = Buffer.create 127 in
 
@@ -72,3 +70,12 @@ let string_of_xml ~enc v=
   document_start ();
   print_elt v;
   Buffer.contents buffer
+
+let print_xml ~utf8 s =
+  try   
+    let s = string_of_xml ~utf8 s in
+    if utf8 then string_utf8 (U.mk s) else string_latin1 s
+  with exn ->
+    raise
+      (Location.Generic (Pxp_types.string_of_exn exn))
+