[r2004-07-13 21:15:18 by afrisch] Merge in branch ocaml308

Original author: afrisch
Date: 2004-07-13 21:15:19+00:00

Makefile.distrib

@@ -254,7 +254,7 @@ validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
 
 cdo2ml: ocamliface/cdo2ml.ml
 	@echo "Build $@"
-	$(HIDE)ocamlc -o $@ -pp camlp4o -I +camlp4 camlp4.cma pr_o.cmo $^
+	$(HIDE)ocamlc -o $@ -pp camlp4o -I +camlp4 odyl.cma camlp4.cma pr_o.cmo $^
 
 .PHONY: compute_depend
 compute_depend: $(DEPEND_OCAMLDEP)

driver/librarian.ml

@@ -43,7 +43,7 @@ let mk ((typing,compile,code),types,ext) =
     stub = None
   }
 
-let magic = "CDUCE:compunit:00003"
+let magic = "CDUCE:compunit:00004"
 
 let obj_path = ref [ "" ]
 
@@ -159,7 +159,8 @@ let rec compile verbose name id src =
     try Parser.prog input 
     with
     | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
-    | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
+(*    | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e *)
+    | Stdpp.Exc_located ((i,j), e) -> raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
   in
   close_in ic;
   let argv = ident (U.mk "argv") in

ocamliface/cdo2ml.ml

 #load "q_MLast.cmo";;
 
-let loc = (-1,-1)
+let loc = (Lexing.dummy_pos, Lexing.dummy_pos)
 
 let usage =
 "Usage: cdo2ml [-static] <module>.cdo

ocamliface/mlstub.ml

@@ -74,7 +74,7 @@ let mk_var _ =
 
 let mk_vars = List.map mk_var
 
-let loc = (-1,-1)
+let loc = (Lexing.dummy_pos,Lexing.dummy_pos)
 
 let let_in p e body =
   <:expr< let $list:[ p, e ]$ in $body$ >>

ocamliface/mltypes.ml

@@ -197,14 +197,14 @@ let read_cmi name =
 	   let (unf,n) = unfold t in
 	   if n !=0 then unsupported "polymorphic value";
 	   values := (Ident.name id, t, unf) :: !values
-       | Tsig_type (id,t) -> 
+       | Tsig_type (id,t,_) -> 
 	   Format.fprintf ppf "%a@." (Printtyp.type_declaration id) t
-       | Tsig_value (_,_) -> unsupported "external value"
-       | Tsig_exception (_,_) -> unsupported "exception"
-       | Tsig_module (_,_) -> unsupported "module"
-       | Tsig_modtype (_,_) -> unsupported "module type"
-       | Tsig_class (_,_) -> unsupported "class"
-       | Tsig_cltype (_,_) -> unsupported "class type"
+       | Tsig_value _ -> unsupported "external value"
+       | Tsig_exception _ -> unsupported "exception"
+       | Tsig_module _ -> unsupported "module"
+       | Tsig_modtype _ -> unsupported "module type"
+       | Tsig_class _ -> unsupported "class"
+       | Tsig_cltype _ -> unsupported "class type"
     ) sg;
   (Buffer.contents buf, !values)
 

parser/parser.ml

@@ -9,8 +9,15 @@ open Printf
 let ()  = Grammar.error_verbose := true
 *)
 
+let tloc (i,j) = (i.Lexing.pos_cnum,j.Lexing.pos_cnum)
+let nopos = (Lexing.dummy_pos, Lexing.dummy_pos)
+
+
+let mk loc x = Location.mk (tloc loc) x
+
 exception Error of string
 let error (i,j) s = Location.raise_loc i j (Error s)
+let error loc s = error (tloc loc) s
 
 let gram    = Grammar.gcreate Ulexer.lex
 
@@ -28,7 +35,7 @@ let pat     = Grammar.Entry.create gram "type/pattern expression"
 let regexp  = Grammar.Entry.create gram "type/pattern regexp"
 let keyword = Grammar.Entry.create gram "keyword"
 		
-let exp pos e = LocatedExpr (loc_of_pos pos,e)
+let exp pos e = LocatedExpr (loc_of_pos (tloc pos),e)
 
 let rec multi_prod loc = function
   | [ x ] -> x
@@ -71,8 +78,8 @@ let localize_exn f =
   try f ()
   with
   | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
-  | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
-  
+(*  | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e *)
+  | Stdpp.Exc_located ((i,j), e) -> raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
 
 let is_fun_decl =
    Grammar.Entry.of_parser gram "[is_fun_decl]"

parser/ulexer.ml

@@ -150,6 +150,21 @@ let raise_clean e =
   (* reinit encoding ? *)
   raise e
 
+let pos_of_int i =
+  { Lexing.pos_fname = "";
+    Lexing.pos_lnum = 0;
+    Lexing.pos_bol = 0;
+    Lexing.pos_cnum = i }
+
+let make_stream_and_location f =
+  Token.make_stream_and_flocation
+    (fun () ->
+       let (tok,(i,j)) = f () in
+       (tok, (pos_of_int i, pos_of_int j))
+    )
+
+
+
 let tok_func cs =
   let lb = L.from_var_enc_stream enc cs in
   (lexer ("#!" [^ '\n']* "\n")? -> ()) lb;
@@ -169,7 +184,7 @@ let tok_func cs =
     last_tok := fst tok;
     tok
   in
-  Token.make_stream_and_location next
+  make_stream_and_location next
       
 let register_kw (s1,s2) =
   if s1 = "" then 

query/query_parse.ml

@@ -8,7 +8,10 @@ open Query
 #load "pa_extend.cmo";;
 
 
-let exp pos e = LocatedExpr (loc_of_pos pos,e)
+let tloc (i,j) = (i.Lexing.pos_cnum,j.Lexing.pos_cnum)
+let mk loc x = Location.mk (tloc loc) x
+
+let exp pos e = LocatedExpr (loc_of_pos (tloc pos),e)
 
 let cst_nil =  Const Sequence.nil_cst
 let parse_ident = U.mk
@@ -39,14 +42,14 @@ EXTEND
 	  match z with
               Some w -> 
                 (w, exp loc 
-		   (Parser.if_then_else (Query.ast_of_bool(w,loc)) 
+		   (Parser.if_then_else (Query.ast_of_bool(w,tloc loc)) 
 		      (Pair (e,cst_nil)) 
 		      cst_nil))
             | None -> (True, exp loc (Pair(e,cst_nil)))
 	in 
 	if !Query.nooptim 
-        then Query.select(loc,fin,l)
-      	else Query.selectOpt(loc,Pair (e,cst_nil),l,condi)
+        then Query.select(tloc loc,fin,l)
+      	else Query.selectOpt(tloc loc,Pair (e,cst_nil),l,condi)
    | 
       e = expr; "/@"; 
       a = [IDENT|keyword]-> (* projection sur 1 attribut *)

types/atoms.ml

@@ -48,7 +48,7 @@ let print_symbolset ns ppf = function
 	(fun x -> V.print_quote ppf (ns,x)) l
   | SymbolSet.Cofinite t ->
       Format.fprintf ppf "@[`%a" V.print_any_in_ns ns;
-      List.iter (fun x -> Format.fprintf ppf " \@ %a" V.print_quote (ns,x)) t;
+      List.iter (fun x -> Format.fprintf ppf " \\@ %a" V.print_quote (ns,x)) t;
       Format.fprintf ppf "@]"
 
 include SortedList.FiniteCofiniteMap(Ns)(SymbolSet)
@@ -72,7 +72,7 @@ let print s = match get s with
 	  Format.fprintf ppf "Atom";
 	  List.iter 
 	    (fun (ns,s) -> 
-	       Format.fprintf ppf " \@ (%a)" (print_symbolset ns) s)
+	       Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
 	    l ]
 
 type 'a map = 'a Imap.s Imap.s

types/types.ml

@@ -421,13 +421,27 @@ struct
 
 end
 
+(* See PR#2920 in OCaml BTS *)
+and NodeT : Custom.T with type t = Node.t =
+struct
+  type t = Node.t
+  let dump x = Node.dump x
+  let check x = Node.check x
+  let equal x = Node.equal x
+  let hash x = Node.hash x
+  let compare x = Node.compare x
+  let serialize x = Node.serialize x
+  let deserialize x = Node.deserialize x
+end
+
+
 (* It is also possible to use Boolean instead of Bool here;
    need to analyze when each one is more efficient *)
 and BoolPair : Bool.S with type elem = Node.t * Node.t = 
-Bool.Make(Custom.Pair(Node)(Node))
+Bool.Make(Custom.Pair(NodeT)(NodeT))
 
 and BoolRec : Bool.S with type elem = bool * Node.t label_map =
-Bool.Make(Custom.Pair(Custom.Bool)(LabelSet.MakeMap(Node)))
+Bool.Make(Custom.Pair(Custom.Bool)(LabelSet.MakeMap(NodeT)))
 
 module DescrHash = Hashtbl.Make(Descr)
 module DescrMap = Map.Make(Descr)