Permalink
Browse files

Owz compiles with locations in longidents and paths

  • Loading branch information...
1 parent cd4f361 commit 6b50d4e7fc1a9bbd3751a42077bf9ddb7e15863c Tiphaine Turpin committed Jul 1, 2011
View
Binary file not shown.
View
Binary file not shown.
View
@@ -44,7 +44,7 @@ SITE_START_DIR=/etc/emacs/site-start.d
OCAMLC = ../boot/ocamlrun ../ocamlc
OCAMLOPT = ../boot/ocamlrun ../ocamlopt
-OCAMLDEP = ../boot/ocamlrun ../ocamldep
+OCAMLDEP = ../boot/ocamlrun ../tool/ocamldep
OCAMLLEX = ../boot/ocamlrun ../boot/ocamllex
OCAMLYACC = ../boot/ocamlyacc
OCAMLDEP = ../boot/ocamlrun ../tools/ocamldep
@@ -78,7 +78,8 @@ let set_match_depth depth =
| _ ->
raise (Arg.Bad ("Completion : illegal match-depth specification"))
-let set_qualid flat_id = qualid := Longident.parse flat_id
+let set_qualid flat_id =
+ qualid := (Longident.parse Location.none flat_id).Longident.lid
let rec parse_lines f =
try
@@ -39,7 +39,7 @@ val include_dirs : string list ref
val fic_source : string ref
val pos : string ref
val absolute_filenames : bool ref
-val qualid : Longident.t ref
+val qualid : Longident.lid ref
val loc : (int * int) ref
val expand_loc : (int * int) ref
val root_dir : string ref
@@ -38,8 +38,8 @@ let mk_option_list lis =
let mk_bool_pats () =
let loc = Location.none in
- let yea = Longident.Lident "true" in
+ let yea = Longident.lident Location.none "true" in
let yea = {ppat_desc = Ppat_construct(yea, None, false); ppat_loc = loc} in
- let no = Longident.Lident "false" in
+ let no = Longident.lident Location.none "false" in
let no = {ppat_desc = Ppat_construct(no, None, false); ppat_loc = loc} in
[yea ; no]
@@ -90,7 +90,7 @@ let pattern_depth pat = (* THIS FUNCTION MUST BE CHECKED *)
| Ppat_construct (_, None ,_) -> d + 1
| Ppat_construct (lid, Some p' ,_) ->
- if lid <> Lident "::" then p_depth (d + 1) p'
+ if lid.lid <> Lident "::" then p_depth (d + 1) p'
else p_depth d p'
| Ppat_variant (_,None) -> d + 1
@@ -173,7 +173,7 @@ let qualif_from_oid oid = function
end
| p_desc -> p_desc
-let is_list (lid:Longident.t) = match lid with
+let is_list (lid:Longident.t) = match lid.lid with
| Lident ("[]"|"(hd :: tl)") -> true
| _ -> false
@@ -196,6 +196,8 @@ module Lpp = struct
| Lident s -> fprintf fmt "%s" s
| Ldot (t, s) -> fprintf fmt "%a.%s" print_lid t s
| Lapply (t, t2) -> fprintf fmt "%a %a" print_lid t print_lid t2
+
+ let print_lid fmt lid = print_lid fmt lid.lid
let rec print_record ?tag_first_wildcard fmt lis =
let (hd_lid,hd_pat),tl = List.hd lis, List.tl lis in
@@ -237,7 +239,7 @@ module Lpp = struct
List.iter (fun p -> fprintf fmt ", %a" print_pattern p.ppat_desc ) r;
fprintf fmt ")"
end
- | Ppat_construct (Lident "::", Some {ppat_desc = Ppat_tuple [t ; q]}, _) ->
+ | Ppat_construct ({lid = Lident "::"}, Some {ppat_desc = Ppat_tuple [t ; q]}, _) ->
fprintf fmt "%a :: %a"
print_pattern t.ppat_desc
print_pattern q.ppat_desc
@@ -18,10 +18,10 @@
val get_c_num : Location.t -> int * int
val module_name : string list -> string
val concat_string_list : string list -> string
-val add_qualif : Longident.t -> Longident.t -> Longident.t
+val add_qualif : Longident.lid -> Longident.lid -> Longident.lid
val max_patterns_depth : Parsetree.pattern list -> int
val pattern_depth : Parsetree.pattern -> int
-val lid_head : Longident.t -> string
+val lid_head : Longident.lid -> string
(** Return the flat path to the module containing the given type. For
example, type_path <A.B.t> = ["A" ; "B"]. *)
@@ -180,10 +180,12 @@ let mk_values ce se (env, _) m i =
(Longident.Lident t)
q
in
+(*
debugln "prefix = %s" (lid_to_str lid);
let mo = Env.lookup_module lid env in
debugln " OK";
- Some lid
+*)
+ Some (Longident.longident Location.none lid)
in
complete_ident m i env
@@ -61,7 +61,7 @@ let best_qualif pat env prefix_lis typ =
| [] ->
begin
try
- let _, const = Env.lookup_constructor lid env in
+ let _, const = Env.lookup_constructor_lid lid env in
(*
if const.cstr_loc = owz_inf then lid else raise Exit
*)
@@ -72,23 +72,23 @@ let best_qualif pat env prefix_lis typ =
if const.cstr_res = typ then lid else raise Exit
with _ ->
if !Common_config.debug then
- Format.eprintf "| [] -> lookup_constr : %s@." (Util.lid_to_str lid);
+ Format.eprintf "| [] -> lookup_constr : %s@." (Util.lid_to_str (longident Location.none lid));
if List.length prefix_lis > 0 && "Unix" = List.hd prefix_lis then(
if !Common_config.debug then
Format.eprintf "> Special case for Unix@.";
lid
)else
- if Util.is_list lid then
+ if Util.is_list (longident Location.none lid) then
lid
else unreachable "Proposal_extraction" 3
end
| p :: r ->
if !Common_config.debug then
Format.eprintf "| p :: r -> lookup_constr : %s@."
- (Util.lid_to_str lid);
+ (Util.lid_to_str (longident Location.none lid));
try
- let _, const = Env.lookup_constructor lid env in
+ let _, const = Env.lookup_constructor_lid lid env in
if const.cstr_res = typ then lid else raise Exit
with _ ->
let up_qualif = add_qualif (Lident p) lid in
@@ -102,11 +102,11 @@ let best_qualif pat env prefix_lis typ =
in
*)
match pat.ppat_desc with
- | Ppat_construct (lid, e1, e2) when lid <> Lident "[]" ->
+ | Ppat_construct (lid, e1, e2) when lid.lid <> Lident "[]" ->
{ pat with
ppat_desc =
- let best_qualif = qualif_lid lid prefix_lis in
- Ppat_construct (best_qualif, e1, e2)
+ let best_qualif = qualif_lid lid.lid prefix_lis in
+ Ppat_construct ((longident Location.none best_qualif), e1, e2)
}
| _ -> pat
@@ -165,7 +165,8 @@ let rec shortest_path cond = function
let rev_lookup_member lookup res tcstr cstr =
let p =
match tcstr with
- | Pdot (p, _, _) -> Ldot (Untypeast.lident_of_path p, cstr)
+ | Pdot (p, _, _) ->
+ Ldot ((Untypeast.lident_of_path (path Location.none p)).lid, cstr)
| Pident _ -> Lident cstr
| _ -> invalid_arg "rev_lookup_cstr"
in
@@ -184,14 +185,14 @@ let rev_lookup_member lookup res tcstr cstr =
let rev_lookup_cstr env tcstr cstr =
rev_lookup_member
- (function p -> Env.lookup_constructor p env)
+ (function p -> Env.lookup_constructor_lid p env)
(function cstr_desc -> cstr_desc.cstr_res)
tcstr
cstr
let rev_lookup_field env tcstr field =
rev_lookup_member
- (function p -> Env.lookup_label p env)
+ (function p -> Env.lookup_label_lid p env)
(function field_desc -> field_desc.lbl_res)
tcstr
field
@@ -222,15 +223,15 @@ let variant_patterns env tcstr cstrs =
in
mk_pattern
(Ppat_construct
- (rev_lookup_cstr env tcstr cstr, arg, false)))
+ (longident Location.none (rev_lookup_cstr env tcstr cstr), arg, false)))
cstrs
let record_pattern env tcstr fields =
mk_pattern
(Ppat_record
(List.map
(function field, _, t ->
- (rev_lookup_field env tcstr field,
+ (longident Location.none (rev_lookup_field env tcstr field),
mk_pattern Ppat_any))
fields,
Asttypes.Closed))
@@ -89,8 +89,8 @@ let given_is_include special_behv gvn my_p =
F.eprintf "|given-lg| = %d and |extracted-lp| = %d@."
(L.length lg)(L.length lp)
end;
- let lg = L.map (fun (nm,ty) -> (Util.lid_head nm,ty)) lg in
- let lp = L.map (fun (nm,ty) -> (Util.lid_head nm,ty)) lp in
+ let lg = L.map (fun (nm,ty) -> (Util.lid_head nm.Longident.lid,ty)) lg in
+ let lp = L.map (fun (nm,ty) -> (Util.lid_head nm.Longident.lid,ty)) lp in
let f_cmp (nm1, _) (nm2, _) = compare nm1 nm2 in
let normalize lnorm = L.filter (fun (nm,_) -> L.mem_assoc nm lnorm) in
@@ -174,8 +174,8 @@ let rec make_projection acc gvn exp_p =
L.fold_left2 make_projection acc l1 l2
| Ppat_record (lg, _), Ppat_record (lp, _) ->
- let lg = L.map (fun (nm,ty) -> (Util.lid_head nm,ty)) lg in
- let lp = L.map (fun (nm,ty) -> (Util.lid_head nm,ty)) lp in
+ let lg = L.map (fun (nm,ty) -> (Util.lid_head nm.Longident.lid,ty)) lg in
+ let lp = L.map (fun (nm,ty) -> (Util.lid_head nm.Longident.lid,ty)) lp in
let f_cmp (nm1, _) (nm2, _) = compare nm1 nm2 in
let normalize lnrm = L.filter (fun (nm,_) -> L.mem_assoc nm lnrm) in
let lp = L.sort f_cmp (normalize lg lp)in
@@ -109,7 +109,7 @@ let label_is_given lbl_name = function
| Faccess _ -> false
| Fdef gvn | Fpat gvn ->
try
- List.iter (fun lid -> if lid_head lid = lbl_name then raise Exit) gvn;
+ List.iter (fun lid -> if lid_head lid.Longident.lid = lbl_name then raise Exit) gvn;
false
with _ -> true
@@ -67,6 +67,8 @@ let rec print_lid fmt = function
| Lident s -> fprintf fmt "%s" s
| Ldot (t, s) -> fprintf fmt "%a.%s" print_lid t s
| Lapply (t, t2) -> fprintf fmt "%a %a" print_lid t print_lid t2
+
+let print_lid fmt lid = print_lid fmt lid.lid
let rec print_record fmt lis =
let (hd_lid,hd_pat),tl = List.hd lis, List.tl lis in
Oops, something went wrong.

0 comments on commit 6b50d4e

Please sign in to comment.