[r2003-05-11 18:16:30 by cvscast] Review identifier in lexer; removed more generic comparisons

Original author: cvscast
Date: 2003-05-11 18:16:31+00:00

driver/cduce.ml

@@ -5,6 +5,11 @@ let quiet = ref false
 
 let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
 
+let rec is_abstraction = function
+  | Ast.Abstraction _ -> true
+  | Ast.LocatedExpr (_,e) -> is_abstraction e
+  | _ -> false
+
 let print_norm ppf d = 
   Location.protect ppf 
     (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
@@ -163,7 +168,7 @@ let run ppf ppf_err input =
 	  let v = Eval.eval Eval.Env.empty e in
 	  if not !quiet then
 	    Format.fprintf ppf "=> @[%a@]@\n@." print_value v
-      | Ast.LetDecl (p,Ast.Abstraction _) -> ()
+      | Ast.LetDecl (p,e) when is_abstraction e -> ()
       | Ast.LetDecl (p,e) ->
 	  let decl = Typer.let_decl p e in
 	  type_decl decl;
@@ -181,7 +186,7 @@ let run ppf ppf_err input =
     List.iter eval_decl decls
   in
   let rec phrases funs = function
-    | { descr = Ast.LetDecl (p,(Ast.Abstraction _ as e)) } :: phs -> 
+    | { descr = Ast.LetDecl (p,e) } :: phs when is_abstraction e -> 
 	phrases ((p,e)::funs) phs
     | ph :: phs ->
 	do_fun_decls funs;
@@ -201,7 +206,7 @@ let run ppf ppf_err input =
       List.fold_left
 	(fun ((typs,funs) as accu) ph -> match ph.descr with
 	   | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
-	   | Ast.LetDecl (p,(Ast.Abstraction _ as e)) -> 
+	   | Ast.LetDecl (p,e) when is_abstraction e -> 
 	       (typs, (p,e)::funs)
 	   | _ -> accu
 	) ([],[]) p in

parser/parser.ml

@@ -125,6 +125,17 @@ EXTEND
     ]
   ];
 
+  keyword: [
+    [ a = 
+	[ "map" | "match" | "with" | "try" | "xtransform"
+	| "if" | "then"	| "else"
+	| "transform" | "fun" | "in"
+	| "let"
+	]
+	-> a
+    ]
+  ];
+
   expr: [
     "top" RIGHTA
     [ "match"; e = SELF; "with"; b = branches -> exp loc (Match (e,b))
@@ -217,9 +228,9 @@ EXTEND
 		  ) l e
 	in
 	exp loc l
-    | t = [ a = TAG -> 
-	      exp loc (Cst (Types.Atom (Atoms.mk a)))
-	  | "<"; e = expr LEVEL "no_appl" -> e ];
+    | "<"; t = [ "("; e = expr; ")" -> e
+	       | a = [ LIDENT | UIDENT | keyword ] -> 
+		     exp loc (Cst (Types.Atom (Atoms.mk a))) ];
 	a = expr_attrib_spec; ">"; c = expr ->
 	exp loc (Xml (t, Pair (a,c)))
     | "{"; r = [ expr_record_spec | -> exp loc (RecordLitt LabelMap.empty) ]; "}" -> r
@@ -325,7 +336,7 @@ EXTEND
   ];
 
   pat: [ 
-      [ x = pat; "where"; 
+      [ x = pat; LIDENT "where"; 
         b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)] SEP "and"
             -> mk loc (Recurs (x,b)) ]
     | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
@@ -363,13 +374,11 @@ EXTEND
              q = [ ";"; q = pat -> q 
                  | -> mknoloc (Internal (Sequence.nil_type)) ]; 
              "]" -> mk loc (Regexp (r,q))
-      | t = [
-	  [ "<"; LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any)))
-	  | a = TAG -> 
-	      mk loc 
-	      (Internal (Types.atom (Atoms.atom (Atoms.mk a)))) ]
-	| [ "<"; t = pat -> t ]
-	];
+      | "<"; t =
+        [ x = [ LIDENT | UIDENT | keyword ] ->
+	    let a = if x = "_" then Atoms.any else Atoms.atom (Atoms.mk x) in
+	    mk loc (Internal (Types.atom a))
+	| "("; t = pat; ")" -> t ];
 	a = attrib_spec; ">"; c = pat ->
           mk loc (XmlT (t, multi_prod loc [a;c]))
       | s = STRING2 ->

parser/wlexer.mll

@@ -7,7 +7,13 @@ classes
    blank 
    lowercase uppercase ascii_digit 
    "_<>=.,:;+-*/@&{}[]()|?`\"\\\'!"
-   
+
+   unicode_base_char
+   unicode_ideographic
+   unicode_combining_char
+   unicode_digit
+   unicode_extender
+
 
 {
   let keywords = Hashtbl.create 17
@@ -49,10 +55,17 @@ classes
   let numeric_char s =
     int_of_string (String.sub s 1 (String.length s - 2))
 
+
+  let hexa_digit = function
+    | '0'..'9' as c -> (Char.code c) - (Char.code '0')
+    | 'a'..'f' as c -> (Char.code c) - (Char.code 'a') + 10
+    | _ -> failwith "Invalid hexadecimal digit" (* TODO: error loc *)
+
+
   let hexa_char s =
     let rec aux i accu =
       if i = String.length s - 1 then accu
-      else aux (succ i) (accu * 16 + Char.code s.[i] - Char.code '0')
+      else aux (succ i) (accu * 16 + hexa_digit s.[i])
     in
     aux 0 0
 
@@ -63,28 +76,42 @@ classes
 
 }
 
+let letter = lowercase | uppercase | unicode_base_char | unicode_ideographic
+let digit = ascii_digit | unicode_digit
+let character = [ ^ encoding_error ]
+
+let ncname_char = 
+  letter | digit | [ ".-_" ] | unicode_combining_char | unicode_extender
+let ncname = (letter | '_' ) ncname_char*
+let qname = (ncname ':')? ncname
+
+(*
+let lident = (lowercase | '_' | unicode_base_char | unicode_ideographic) 
+	       name_char*
+let uident = uppercase name_char*
+*)
 
+(*
 let identchar = lowercase | uppercase | ascii_digit | '_' | '\'' | '-'
 let ident = identchar* ( ':' identchar+)*
+*)
 
 rule token = parse
     blank+    { token engine lexbuf }
-  | (lowercase | '_') ident { 
-      let s = Lexing.lexeme lexbuf in
-      if Hashtbl.mem keywords s then "",s else "LIDENT",s
-    }
-  | uppercase ident { "UIDENT",Lexing.lexeme lexbuf }
-  | '-'? ascii_digit+ { "INT",Lexing.lexeme lexbuf }
-  | "<" blank* (lowercase | uppercase) ident {
-      let s = Lexing.lexeme lexbuf in
-      "TAG", tag_of_tag s 1
-    }
+  | qname 
+      { 
+	let s = Lexing.lexeme lexbuf in
+	if (s.[0] >= 'A') && (s.[0] <= 'Z') 
+	then "UIDENT",s
+	else if Hashtbl.mem keywords s then "",s else "LIDENT",s
+      }
+  | '-'? ascii_digit+ 
+    { "INT",Lexing.lexeme lexbuf }
   | [ "<>=.,:;+-*/@&{}[]()|?`!" ]
   | "->" | "::" | ";;" | "--" | ":=" | "\\" | "++"
   | "{|" | "|}" | "<=" | ">=" | "<<" | ">>"
   | ["?+*"] "?"
 	{ "",Lexing.lexeme lexbuf }
-
   | '"' | "'"
       { let string_start = Lexing.lexeme_start lexbuf in
         string_start_pos := string_start;
@@ -167,7 +194,7 @@ and string ender = parse
         string ender engine lexbuf }
 
 and parse_hexa_char = parse
-  | ascii_digit+ ';'
+  | (ascii_digit|lowercase)+ ';'
       { store_len ~add:2 lexbuf;
 	store_code (hexa_char (Lexing.lexeme lexbuf)) }
   | _
@@ -181,51 +208,160 @@ and parse_hexa_char = parse
   let delta_loc = ref 0
   let set_delta_loc dl = delta_loc := dl
 
-let lexer_func_of_wlex lexfun lexengine cs =
-  let dl = !delta_loc in
-  delta_loc := 0;
-  let lb =
-    Lexing.from_function
-      (fun s n ->
-         try s.[0] <- Stream.next cs; 1 with Stream.Failure -> 0)
-  in
-  let next () =
-    let tok = lexfun lexengine lb in
-    let loc = (Lexing.lexeme_start lb + dl, 
-	       Lexing.lexeme_end lb + dl) in
-    (tok, loc) 
-  in
-  Token.make_stream_and_location next
-
-let register_kw (s1,s2) =
-  if s1 = "" then 
-    match s2.[0] with 
-      | 'a' .. 'z' when not (Hashtbl.mem keywords s2) -> 
-	  Hashtbl.add keywords s2 ()      
-      | _ -> ()
-
-
-let lexer lexfun lexengine =
-  { 
-    Token.tok_func = lexer_func_of_wlex lexfun lexengine; 
-    Token.tok_using = register_kw;
-    Token.tok_removing = (fun _ -> ()); 
-    Token.tok_match = Token.default_match;
-    Token.tok_text = Token.lexer_text 
-  }
+  let lexer_func_of_wlex lexfun lexengine cs =
+    let dl = !delta_loc in
+    delta_loc := 0;
+    let lb =
+      Lexing.from_function
+	(fun s n ->
+           try s.[0] <- Stream.next cs; 1 with Stream.Failure -> 0)
+    in
+    let next () =
+      let tok = lexfun lexengine lb in
+      let loc = (Lexing.lexeme_start lb + dl, 
+		 Lexing.lexeme_end lb + dl) in
+      (tok, loc) 
+    in
+    Token.make_stream_and_location next
+      
+  let register_kw (s1,s2) =
+    if s1 = "" then 
+      match s2.[0] with 
+	| 'a' .. 'z' when not (Hashtbl.mem keywords s2) -> 
+	    Hashtbl.add keywords s2 ()      
+	| _ -> ()
+
+
+  let lexer lexfun lexengine =
+    { 
+      Token.tok_func = lexer_func_of_wlex lexfun lexengine; 
+      Token.tok_using = register_kw;
+      Token.tok_removing = (fun _ -> ()); 
+      Token.tok_match = Token.default_match;
+      Token.tok_text = Token.lexer_text 
+    }
 
   let classes = 
     let c i = (i,i) in
     let i ch1 ch2 = (Char.code ch1, Char.code ch2) in
-    [ (ascii_digit, [i '0' '9']);
-      (lowercase, [i 'a' 'z']);
-      (uppercase, [i 'A' 'Z']);
-      (blank, [c 8; c 9; c 10; c 13; c 32]);
+    [ unicode_base_char,
+      [ 0x00C0,0x00D6; 0x00D8,0x00F6; 
+	0x00F8,0x00FF; 0x0100,0x0131; 0x0134,0x013E; 0x0141,0x0148; 
+	0x014A,0x017E; 0x0180,0x01C3; 0x01CD,0x01F0; 0x01F4,0x01F5; 
+	0x01FA,0x0217; 0x0250,0x02A8; 0x02BB,0x02C1; 0x0386,0x0386;
+	0x0388,0x038A; 0x038C,0x038C; 0x038E,0x03A1; 0x03A3,0x03CE; 
+	0x03D0,0x03D6; 0x03DA,0x03DA; 0x03DC,0x03DC; 0x03DE,0x03DE; 
+	0x03E0,0x03E0; 0x03E2,0x03F3; 
+	0x0401,0x040C; 0x040E,0x044F; 0x0451,0x045C; 0x045E,0x0481; 
+	0x0490,0x04C4; 0x04C7,0x04C8; 0x04CB,0x04CC; 0x04D0,0x04EB; 
+	0x04EE,0x04F5; 0x04F8,0x04F9; 0x0531,0x0556; 0x0559,0x0559;
+	0x0561,0x0586; 0x05D0,0x05EA; 0x05F0,0x05F2; 0x0621,0x063A; 
+	0x0641,0x064A; 0x0671,0x06B7; 0x06BA,0x06BE; 0x06C0,0x06CE; 
+	0x06D0,0x06D3; 0x06D5,0x06D5; 0x06E5,0x06E6; 0x0905,0x0939; 
+	0x093D,0x093D;
+	0x0958,0x0961; 0x0985,0x098C; 0x098F,0x0990; 0x0993,0x09A8; 
+	0x09AA,0x09B0; 0x09B2,0x09B2; 0x09B6,0x09B9; 0x09DC,0x09DD; 
+	0x09DF,0x09E1; 0x09F0,0x09F1; 0x0A05,0x0A0A; 0x0A0F,0x0A10; 
+	0x0A13,0x0A28; 0x0A2A,0x0A30; 0x0A32,0x0A33; 0x0A35,0x0A36; 
+	0x0A38,0x0A39; 0x0A59,0x0A5C; 0x0A5E,0x0A5E; 0x0A72,0x0A74; 
+	0x0A85,0x0A8B; 0x0A8D,0x0A8D; 0x0A8F,0x0A91; 0x0A93,0x0AA8; 
+	0x0AAA,0x0AB0; 0x0AB2,0x0AB3; 0x0AB5,0x0AB9; 0x0ABD,0x0ABD; 
+	0x0AE0,0x0AE0;
+	0x0B05,0x0B0C; 0x0B0F,0x0B10; 0x0B13,0x0B28; 0x0B2A,0x0B30; 
+	0x0B32,0x0B33; 0x0B36,0x0B39; 0x0B3D,0x0B3D; 0x0B5C,0x0B5D; 
+	0x0B5F,0x0B61; 0x0B85,0x0B8A; 0x0B8E,0x0B90; 0x0B92,0x0B95; 
+	0x0B99,0x0B9A; 0x0B9C,0x0B9C; 0x0B9E,0x0B9F; 0x0BA3,0x0BA4; 
+	0x0BA8,0x0BAA; 0x0BAE,0x0BB5; 0x0BB7,0x0BB9; 0x0C05,0x0C0C; 
+	0x0C0E,0x0C10; 0x0C12,0x0C28; 0x0C2A,0x0C33; 0x0C35,0x0C39; 
+	0x0C60,0x0C61; 0x0C85,0x0C8C; 0x0C8E,0x0C90; 0x0C92,0x0CA8; 
+	0x0CAA,0x0CB3; 0x0CB5,0x0CB9; 0x0CDE,0x0CDE; 0x0CE0,0x0CE1; 
+	0x0D05,0x0D0C; 0x0D0E,0x0D10; 0x0D12,0x0D28; 0x0D2A,0x0D39; 
+	0x0D60,0x0D61; 0x0E01,0x0E2E; 0x0E30,0x0E30; 0x0E32,0x0E33; 
+	0x0E40,0x0E45; 0x0E81,0x0E82; 0x0E84,0x0E84; 0x0E87,0x0E88; 
+	0x0E8A,0x0E8A;
+	0x0E8D,0x0E8D; 0x0E94,0x0E97; 0x0E99,0x0E9F; 0x0EA1,0x0EA3; 
+	0x0EA5,0x0EA5;
+	0x0EA7,0x0EA7; 0x0EAA,0x0EAB; 0x0EAD,0x0EAE; 0x0EB0,0x0EB0; 
+	0x0EB2,0x0EB3;
+	0x0EBD,0x0EBD; 0x0EC0,0x0EC4; 0x0F40,0x0F47; 0x0F49,0x0F69; 
+	0x10A0,0x10C5; 0x10D0,0x10F6; 0x1100,0x1100; 0x1102,0x1103; 
+	0x1105,0x1107; 0x1109,0x1109; 0x110B,0x110C; 0x110E,0x1112; 
+	0x113C,0x113C;
+	0x113E,0x113E; 0x1140,0x1140; 0x114C,0x114C; 0x114E,0x114E; 
+	0x1150,0x1150; 0x1154,0x1155; 0x1159,0x1159;
+	0x115F,0x1161; 0x1163,0x1163; 0x1165,0x1165; 0x1167,0x1167; 
+	0x1169,0x1169; 0x116D,0x116E; 
+	0x1172,0x1173; 0x1175,0x1175; 0x119E,0x119E; 0x11A8,0x11A8; 
+	0x11AB,0x11AB; 0x11AE,0x11AF; 
+	0x11B7,0x11B8; 0x11BA,0x11BA; 0x11BC,0x11C2; 0x11EB,0x11EB; 
+	0x11F0,0x11F0; 0x11F9,0x11F9;
+	0x1E00,0x1E9B; 0x1EA0,0x1EF9; 0x1F00,0x1F15; 0x1F18,0x1F1D; 
+	0x1F20,0x1F45; 0x1F48,0x1F4D; 0x1F50,0x1F57; 0x1F59,0x1F59; 
+	0x1F5B,0x1F5B;
+	0x1F5D,0x1F5D; 0x1F5F,0x1F7D; 0x1F80,0x1FB4; 0x1FB6,0x1FBC; 
+	0x1FBE,0x1FBE;
+	0x1FC2,0x1FC4; 0x1FC6,0x1FCC; 0x1FD0,0x1FD3; 0x1FD6,0x1FDB; 
+	0x1FE0,0x1FEC; 0x1FF2,0x1FF4; 0x1FF6,0x1FFC; 0x2126,0x2126;
+	0x212A,0x212B; 0x212E,0x212E; 0x2180,0x2182; 0x3041,0x3094; 
+	0x30A1,0x30FA; 0x3105,0x312C; (* 0xAC00,0xD7A3 *) ];
+
+      unicode_ideographic,
+      [ 0x3007,0x3007; 0x3021,0x3029 (* 0x4E00-0x9FA5 *) ];
+
+      unicode_combining_char,
+      [ 0x0300,0x0345; 0x0360,0x0361; 0x0483,0x0486; 0x0591,0x05A1;
+	0x05A3,0x05B9; 0x05BB,0x05BD; 0x05BF,0x05BF; 0x05C1,0x05C2;
+	0x05C4,0x05C4; 0x064B,0x0652; 0x0670,0x0670; 0x06D6,0x06DC;
+	0x06DD,0x06DF; 0x06E0,0x06E4; 0x06E7,0x06E8; 0x06EA,0x06ED;
+	0x0901,0x0903; 0x093C,0x093C; 0x093E,0x094C; 0x094D,0x094D;
+	0x0951,0x0954; 0x0962,0x0963; 0x0981,0x0983; 0x09BC,0x09BC;
+	0x09BE,0x09BE; 0x09BF,0x09BF; 0x09C0,0x09C4; 0x09C7,0x09C8;
+	0x09CB,0x09CD; 0x09D7,0x09D7; 0x09E2,0x09E3; 0x0A02,0x0A02;
+	0x0A3C,0x0A3C; 0x0A3E,0x0A3E; 0x0A3F,0x0A3F; 0x0A40,0x0A42;
+	0x0A47,0x0A48; 0x0A4B,0x0A4D; 0x0A70,0x0A71; 0x0A81,0x0A83;
+	0x0ABC,0x0ABC; 0x0ABE,0x0AC5; 0x0AC7,0x0AC9; 0x0ACB,0x0ACD;
+	0x0B01,0x0B03; 0x0B3C,0x0B3C; 0x0B3E,0x0B43; 0x0B47,0x0B48;
+	0x0B4B,0x0B4D; 0x0B56,0x0B57; 0x0B82,0x0B83; 0x0BBE,0x0BC2;
+	0x0BC6,0x0BC8; 0x0BCA,0x0BCD; 0x0BD7,0x0BD7; 0x0C01,0x0C03;
+	0x0C3E,0x0C44; 0x0C46,0x0C48; 0x0C4A,0x0C4D; 0x0C55,0x0C56;
+	0x0C82,0x0C83; 0x0CBE,0x0CC4; 0x0CC6,0x0CC8; 0x0CCA,0x0CCD;
+	0x0CD5,0x0CD6; 0x0D02,0x0D03; 0x0D3E,0x0D43; 0x0D46,0x0D48;
+	0x0D4A,0x0D4D; 0x0D57,0x0D57; 0x0E31,0x0E31; 0x0E34,0x0E3A;
+	0x0E47,0x0E4E; 0x0EB1,0x0EB1; 0x0EB4,0x0EB9; 0x0EBB,0x0EBC;
+	0x0EC8,0x0ECD; 0x0F18,0x0F19; 0x0F35,0x0F35; 0x0F37,0x0F37;
+	0x0F39,0x0F39; 0x0F3E,0x0F3E; 0x0F3F,0x0F3F; 0x0F71,0x0F84;
+	0x0F86,0x0F8B; 0x0F90,0x0F95; 0x0F97,0x0F97; 0x0F99,0x0FAD;
+	0x0FB1,0x0FB7; 0x0FB9,0x0FB9; 0x20D0,0x20DC; 0x20E1,0x20E1;
+	0x302A,0x302F; 0x3099,0x3099; 0x309A,0x309A ];
+
+      unicode_digit,
+      [ 0x0660,0x0669; 0x06F0,0x06F9; 0x0966,0x096F; 0x09E6,0x09EF;
+	0x0A66,0x0A6F; 0x0AE6,0x0AEF; 0x0B66,0x0B6F; 0x0BE7,0x0BEF;
+	0x0C66,0x0C6F; 0x0CE6,0x0CEF; 0x0D66,0x0D6F; 0x0E50,0x0E59;
+	0x0ED0,0x0ED9; 0x0F20,0x0F29 ];
+
+
+      unicode_extender,
+      [ 0x00B7,0x00B7; 0x02D0,0x02D1; 0x0387,0x0387; 0x0640,0x0640;
+	0x0E46,0x0E46; 0x0EC6,0x0EC6; 0x3005,0x3005; 0x3031,0x3035;
+	0x309D,0x309E; 0x30FC,0x30FE ];
+
+      ascii_digit, 
+      [ i '0' '9'];
+
+      lowercase, 
+      [i 'a' 'z'];
+
+      uppercase, 
+      [i 'A' 'Z'];
+      
+      blank, 
+      [c 8; c 9; c 10; c 13; c 32]
     ]
 
   let table =
     assert(nb_classes <= 256);
-    let v = String.make 256 (Char.chr encoding_error) in
+    let v = String.make 0x312d (Char.chr encoding_error) in
     let fill_int c (i, j) = String.fill v i (j-i+1) c in
     let fill_class (c, l) = List.iter (fill_int (Char.chr c)) l in
     let fill_char  (ch, cl) = v.[ch] <- Char.chr cl in
@@ -233,10 +369,17 @@ let lexer lexfun lexengine =
     List.iter fill_char one_char_classes;
     v
 
-  let utf8_engine = Lex_engines.engine_tiny_utf8 table
-                      (fun c -> 
-                         if c>=0x10000 && c < 0x11000 then xml_char
-                         else encoding_error)
+  let utf8_engine = 
+    Lex_engines.engine_tiny_utf8 table
+      (fun code -> 
+	 if code >= 0x4E00 && code <= 0x9FA5 then
+           unicode_ideographic
+	 else if code >= 0xAC00 && code <= 0xD7A3 then
+           unicode_base_char
+	 else if code <= 0xD7FF || (code >= 0xE000 && code <= 0xFFFD) ||
+           (code >= 0x10000 && code <= 0x10FFFF) then
+             xml_char
+	 else encoding_error)
 
   let latin1_engine = Lex_engines.engine_tiny_8bit table
 }

runtime/eval.ml

@@ -100,7 +100,7 @@ and eval_branches env brs arg =
   let (bind, e) = rhs.(code) in
   let env = 
     List.fold_left (fun env (x,i) -> 
-		  if (i = -1) then Env.add x arg env 
+		  if (i == -1) then Env.add x arg env 
 		  else Env.add x bindings.(i) env) env (IdMap.get bind) in
   eval env e
 
@@ -108,7 +108,7 @@ and eval_let_decl env l =
   let v = eval env l.Typed.let_body in
   let (disp,bind) = Typed.dispatcher_let_decl l in
   let (_,bindings) = run_dispatcher disp v in
-  List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) (IdMap.get bind)
+  List.map (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) (IdMap.get bind)
 
 and eval_map env brs = function
   | Pair (x,y) -> 
@@ -233,7 +233,7 @@ and eval_string_of v =
     
 and eval_equal v1 v2 =
   let c = Value.compare v1 v2 in
-  Value.vbool (Value.compare v1 v2 = 0)
+  Value.vbool (Value.compare v1 v2 == 0)
 
 and eval_lt v1 v2 =
   let c = Value.compare v1 v2 in

runtime/run_dispatch.ml

@@ -5,6 +5,10 @@
        (precompute this ...)
 *)
 
+(*
+let (<) : int -> int -> bool = (<);;
+*)
+
 open Value
 open Ident
 open Patterns.Compile
@@ -31,7 +35,7 @@ let ensure_room n =
 
 let make_result_prod v1 r1 v2 r2 v (code,r) = 
   let n = Array.length r in
-  if n = 0 then code else (
+  if n == 0 then code else (
   ensure_room n;
   let buf = !buffer in
   let c = !cursor in
@@ -47,13 +51,13 @@ let make_result_prod v1 r1 v2 r2 v (code,r) =
     in
     buf.(c + a) <- x
   done;
-  if r1 <> c then blit buf c buf r1 n;
+  if r1 != c then blit buf c buf r1 n;
   cursor := r1 + n;  (* clean space for GC ? *)
   code )
 
 let make_result_basic v (code,r) = 
   let n = Array.length r in
-  if n = 0 then code else (
+  if n == 0 then code else (
   ensure_room n;
   let buf = !buffer in
   for a = 0 to n - 1 do
@@ -70,7 +74,7 @@ let make_result_basic v (code,r) =
 
 let make_result_char ch (code,r) = 
   let n = Array.length r in
-  if n = 0 then code else (
+  if n == 0 then code else (
   ensure_room n;
   let buf = !buffer in
   for a = 0 to n - 1 do
@@ -85,11 +89,11 @@ let make_result_char ch (code,r) =
   code )
 
 let tail_string_latin1 i j s q =
-  if i + 1 = j then q else String_latin1 (i + 1,j,s,q)
+  if i + 1 == j then q else String_latin1 (i + 1,j,s,q)
 
 let make_result_string_latin1 i j s q r1 r2 (code,r) = 
   let n = Array.length r in
-  if n = 0 then code else (
+  if n == 0 then code else (
   ensure_room n;
   let buf = !buffer in
   for a = 0 to n - 1 do
@@ -104,7 +108,7 @@ let make_result_string_latin1 i j s q r1 r2 (code,r) =
     in
     buf.(!cursor + a) <- x
   done;
-  if r1 <> !cursor then blit buf !cursor buf r1 n;
+  if r1 != !cursor then blit buf !cursor buf r1 n;
   cursor := r1 + n;
   code )
 
@@ -114,7 +118,7 @@ let tail_string_utf8 i j s q =
 
 let make_result_string_utf8 i j s q r1 r2 (code,r) = 
   let n = Array.length r in
-  if n = 0 then code else (
+  if n == 0 then code else (
   ensure_room n;
   let buf = !buffer in
   for a = 0 to n - 1 do
@@ -129,7 +133,7 @@ let make_result_string_utf8 i j s q r1 r2 (code,r) =
     in
     buf.(!cursor + a) <- x
   done;
-  if r1 <> !cursor then blit buf !cursor buf r1 n;
+  if r1 != !cursor then blit buf !cursor buf r1 n;
   cursor := r1 + n;
   code )
 
@@ -191,7 +195,7 @@ and run_disp_record other v fields = function
   | Some (RecLabel (l,d)) ->
       let rec aux other = function
 	| (l1,_) :: rem when l1 < l -> aux true rem
-	| (l1,vl) :: rem when l1 = l ->
+	| (l1,vl) :: rem when l1 == l ->
 	    run_disp_record1 other vl rem d
 	| rem -> 
 	    run_disp_record1 other Absent rem d
@@ -228,7 +232,7 @@ and run_disp_record_loop other rem d =
   
 
 and run_disp_string_latin1 i j s q actions = 
-  if i = j then run_disp_kind actions q 
+  if i == j then run_disp_kind actions q 
   else match actions.prod with
     | Impossible -> assert false
     | TailCall d1 -> run_disp_string_latin1_char d1 (Chars.mk_char s.[i])

types/chars.ml

@@ -48,6 +48,16 @@ let rec equal l1 l2 =
     | (i1,j1)::l1, (i2,j2)::l2 -> (i1==i2) && (j1==j2) && (equal l1 l2)
     | _ -> false
 
+let rec  compare (l1 : t) (l2 : t) =
+  match (l1,l2) with
+    | (i1,j1)::l1, (i2,j2)::l2 ->
+	let c = vcompare i1 i2 in if c <> 0 then c 
+	else let c = vcompare j1 j2 in if c <> 0 then c
+	else compare l1 l2
+    | [],[] -> 0
+    | _::_, [] -> -1
+    | _ -> 1
+
 let from_int c = 
   if (c < 0) || (c > max_char) then 
     failwith "Chars.from_int: code point out of bound";

types/chars.mli

@@ -12,6 +12,7 @@ type t (* = (Unichar.t * Unichar.t) list *)
 val equal : t -> t -> bool
 val hash  : int -> t -> int
 val print : t -> (Format.formatter -> unit) list
+val compare : t -> t -> int
 
 val empty : t
 val any   : t

types/intervals.ml

@@ -25,6 +25,32 @@ type interval =
 
 type t = interval list
 
+let rec compare l1 l2 =
+  match (l1,l2) with
+    | [], [] -> 0
+    | [],_ -> -1
+    | _,[] -> 1
+    | Bounded (a1,b1) :: l1, Bounded (a2,b2) :: l2 ->
+	let c = vcompare a1 a2 in if c <> 0 then c 
+	else let c = vcompare b1 b2 in if c <> 0 then c
+	else compare l1 l2
+    | Bounded (_,_) :: _, _ -> -1
+    | _, Bounded (_,_) :: _ -> 1
+
+    | Left a1 :: l1, Left a2 :: l2 ->
+	let c = vcompare a1 a2 in if c <> 0 then c 
+	else compare l1 l2
+    | Left _ :: _, _ -> -1
+    | _, Left _ :: _ -> 1
+
+    | Right a1 :: l1, Right a2 :: l2 ->
+	let c = vcompare a1 a2 in if c <> 0 then c 
+	else compare l1 l2
+    | Right _ :: _, _ -> -1
+    | _, Right _ :: _ -> 1
+
+    | Any :: _, Any :: _ -> 0
+
 
 let rec equal l1 l2 =
   (l1 == l2) ||

types/intervals.mli

@@ -16,6 +16,7 @@ type t
 val equal : t -> t -> bool
 val hash  : int -> t -> int
 val print : t -> (Format.formatter -> unit) list
+val compare : t -> t -> int
 
 val empty : t
 val any   : t

types/patterns.ml

@@ -3,9 +3,13 @@ open Ident
 
 (*
 To be sure not to use generic comparison ...
-let (=) x y = 1
-let (<) : int -> int -> bool = (<)
 *)
+let (=) : int -> int -> bool = (==)