file locations: a lot of cleaning

src/core/ident.ml

@@ -74,6 +74,7 @@ let end_regexp = Str.regexp "end:\\([0-9]+\\)"
 
 let id_fresh ?(labels = []) nm = create_ident nm Fresh labels
 let id_user ?(labels = []) nm loc =
+(*
   let (f,li,b,e) = Loc.extract loc in
   let f = ref f in
   let li = ref li in
@@ -101,6 +102,8 @@ let id_user ?(labels = []) nm loc =
      {Lexing.pos_fname = !f; Lexing.pos_lnum = !li;
       Lexing.pos_bol = 0; Lexing.pos_cnum = !e})
   in
+*)
+  let l = labels in
   create_ident nm (User loc) l
 
 let id_derive ?(labels = []) nm id = create_ident nm (Derived id) labels

src/driver/driver_lexer.mll

@@ -98,7 +98,7 @@ rule token = parse
       { raise (IllegalCharacter c) }
 
 {
-  let loc lb = (lexeme_start_p lb, lexeme_end_p lb)
+  let loc lb = Loc.extract (lexeme_start_p lb, lexeme_end_p lb)
 
   let with_location f lb =
     try f lb with e -> raise (Loc.Located (loc lb, e))

src/driver/driver_parser.mly

@@ -20,8 +20,8 @@
 %{
   open Driver_ast
   open Parsing
-  let loc () = (symbol_start_pos (), symbol_end_pos ())
-  let loc_i i = (rhs_start_pos i, rhs_end_pos i)
+  let loc () = Loc.extract (symbol_start_pos (), symbol_end_pos ())
+  let loc_i i = Loc.extract (rhs_start_pos i, rhs_end_pos i)
   let infix s = "infix " ^ s
   let prefix s = "prefix " ^ s
 %}

src/ide/gmain.ml

@@ -204,14 +204,14 @@ let () =
 
 
 let read_file fn =
-  let fn = Filename.concat project_dir fn in 
+  let fn = Filename.concat project_dir fn in
   let theories = Env.read_file gconfig.env fn in
   let theories =
     Theory.Mnm.fold
       (fun name th acc ->
          match th.Theory.th_name.Ident.id_origin with
-           | Ident.User l -> (Loc.extract l,name,th)::acc
-           | _ -> (Loc.dummy_floc,name,th)::acc)
+           | Ident.User l -> (l,name,th)::acc
+           | _ -> (Loc.dummy_position,name,th)::acc)
       theories []
   in
   let theories = List.sort
@@ -554,21 +554,21 @@ module Helpers = struct
     | Running -> !image_running
     | InternalFailure _ -> !image_failure
     | Done r -> match r.Call_provers.pr_answer with
-	| Call_provers.Valid -> 
-	    if obsolete then !image_valid else !image_valid_obs
-	| Call_provers.Invalid -> 
-	    if obsolete then !image_invalid else !image_invalid_obs
-	| Call_provers.Timeout -> 
-	    if obsolete then !image_timeout else !image_timeout_obs
-	| Call_provers.Unknown _ -> 
-	    if obsolete then !image_unknown else !image_unknown_obs
-	| Call_provers.Failure _ -> 
-	    if obsolete then !image_failure else !image_failure_obs
-	| Call_provers.HighFailure -> 
-	    if obsolete then !image_failure else !image_failure_obs
+	| Call_provers.Valid ->
+	    if obsolete then !image_valid_obs else !image_valid
+	| Call_provers.Invalid ->
+	    if obsolete then !image_invalid_obs else !image_invalid
+	| Call_provers.Timeout ->
+	    if obsolete then !image_timeout_obs else !image_timeout
+	| Call_provers.Unknown _ ->
+	    if obsolete then !image_unknown_obs else !image_unknown
+	| Call_provers.Failure _ ->
+	    if obsolete then !image_failure_obs else !image_failure
+	| Call_provers.HighFailure ->
+	    if obsolete then !image_failure_obs else !image_failure
 
   let set_row_status b row =
-    if b then 
+    if b then
       begin
 	goals_view#collapse_row (goals_model#get_path row);
 	goals_model#set ~row ~column:status_column !image_yes;
@@ -600,13 +600,13 @@ module Helpers = struct
       end
 
   let rec check_goal_proved g =
-    let b1 = Hashtbl.fold 
-      (fun _ a acc -> acc || 
+    let b1 = Hashtbl.fold
+      (fun _ a acc -> acc ||
 	 match a.proof_state with
 	   | Done { Call_provers.pr_answer = Call_provers.Valid} -> true
 	   | _ -> false) g.external_proofs false
     in
-    let b = Hashtbl.fold 
+    let b = Hashtbl.fold
       (fun _ t acc -> acc || t.transf_proved) g.transformations b1
     in
     if g.proved <> b then
@@ -626,7 +626,7 @@ module Helpers = struct
 	set_row_status b t.transf_row;
 	check_goal_proved t.parent_goal
       end
-    
+
 
   (* deprecated *)
   let set_file_verified f =
@@ -678,9 +678,9 @@ module Helpers = struct
     let row = a.proof_row in
     goals_model#set ~row ~column:status_column
       (image_of_result ~obsolete res);
-    
+
     let t = match res with
-      | Done { Call_provers.pr_time = time } -> 
+      | Done { Call_provers.pr_time = time } ->
           Format.sprintf "%.2f" time
       | _ -> ""
     in
@@ -859,7 +859,7 @@ let trans_list =
 
 let trans_of_name =
   let h = Hashtbl.create 13 in
-  List.iter 
+  List.iter
     (fun n -> Hashtbl.add h n (lookup_trans n))
     trans_list;
   Hashtbl.find h
@@ -873,20 +873,20 @@ exception Not_applicable
 
 let apply_trans t task =
   match t with
-    | Trans_one t -> 
+    | Trans_one t ->
 	let t' = Trans.apply t task in
 	if task == t' then raise Not_applicable; [t']
-    | Trans_list t -> 
+    | Trans_list t ->
 	match Trans.apply t task with
 	  | [t'] as l -> if task == t' then raise Not_applicable; l
 	  | l -> l
 
 let apply_transformation ~callback t task =
    match t with
-    | Trans_one t -> 
+    | Trans_one t ->
 	let callback t = callback [t] in
 	Scheduler.apply_transformation ~callback t task
-    | Trans_list t -> 
+    | Trans_list t ->
 	Scheduler.apply_transformation_l ~callback t task
 
 
@@ -916,8 +916,8 @@ let rec reimport_any_goal parent gid gname t db_goal goal_obsolete =
 		 }
 	 in
          let (_pa : Model.proof_attempt) =
-           Helpers.add_external_proof_row ~obsolete ~edit goal p a 
-	     (Scheduler.Done r) 
+           Helpers.add_external_proof_row ~obsolete ~edit goal p a
+	     (Scheduler.Done r)
          in
          ((* something TODO ?*))
        with Not_found ->
@@ -1158,11 +1158,11 @@ let redo_external_proof q g a =
     a.Model.proof_state <- result;
 *)
     Helpers.set_proof_state ~obsolete:false a result (*time*) ;
-    let db_res, time = 
+    let db_res, time =
       match result with
-	| Scheduler.Scheduled | Scheduler.Running -> 
+	| Scheduler.Scheduled | Scheduler.Running ->
 	    Db.Undone, 0.0
-	| Scheduler.InternalFailure _ -> 
+	| Scheduler.InternalFailure _ ->
 	    Db.Done Call_provers.HighFailure, 0.0
 	| Scheduler.Done r ->
 	    if r.Call_provers.pr_answer = Call_provers.Valid then
@@ -1246,19 +1246,19 @@ let prover_on_selected_goals pr =
 let transformation_on_goal g trans_name trans =
   if not g.Model.proved then
     let callback subgoals =
-      ignore 
-	(Thread.create 
+      ignore
+	(Thread.create
 	   (fun subgoals ->
 	      let b =
  		match subgoals with
-		  | [task] -> 
+		  | [task] ->
                       let s1 = task_checksum g.Model.task in
                       let s2 = task_checksum task in
 (*
                       eprintf "Transformation returned only one task. sum before = %s, sum after = %s@." (task_checksum g.Model.task) (task_checksum task);
                       eprintf "addresses: %x %x@." (Obj.magic g.Model.task) (Obj.magic task);
 *)
-                      s1 <> s2 
+                      s1 <> s2
                         (* task != g.Model.task *)
 		  | _ -> true
 	      in
@@ -1269,27 +1269,27 @@ let transformation_on_goal g trans_name trans =
 		  (GtkThread.sync Db.add_transformation)
 		    g.Model.goal_db transf_id
 		in
-		let tr = (GtkThread.sync Helpers.add_transformation_row) 
-		  g db_transf trans_name 
+		let tr = (GtkThread.sync Helpers.add_transformation_row)
+		  g db_transf trans_name
 		in
 		let goal_name = g.Model.goal_name in
-		let fold = 
+		let fold =
 		  fun (acc,count) subtask ->
 		    let _id = (Task.task_goal subtask).Decl.pr_name in
 		    let subgoal_name =
 		      goal_name ^ "." ^ (string_of_int count)
 		    in
 		    let sum = task_checksum subtask in
-		    let subtask_db = 
-		      Db.add_subgoal db_transf subgoal_name sum 
+		    let subtask_db =
+		      Db.add_subgoal db_transf subgoal_name sum
 		    in
 		    let goal =
-		      Helpers.add_goal_row (Model.Transf tr) 
+		      Helpers.add_goal_row (Model.Transf tr)
 			subgoal_name None subtask subtask_db
 		    in
-		    (goal :: acc, count+1) 
+		    (goal :: acc, count+1)
 		in
-		let goals,_ = 
+		let goals,_ =
 		  List.fold_left (GtkThread.sync fold) ([],1) subgoals
 		in
 		tr.Model.subgoals <- List.rev goals;
@@ -1306,7 +1306,7 @@ let rec split_goal_or_children g =
   if not g.Model.proved then
     begin
       let r = ref true in
-      Hashtbl.iter 
+      Hashtbl.iter
 	(fun _ t ->
 	   r := false;
            List.iter split_goal_or_children
@@ -1318,7 +1318,7 @@ let rec inline_goal_or_children g =
   if not g.Model.proved then
     begin
       let r = ref true in
-      Hashtbl.iter 
+      Hashtbl.iter
 	(fun _ t ->
 	   r := false;
            List.iter inline_goal_or_children
@@ -1780,7 +1780,7 @@ let color_loc (v:GSourceView2.source_view) l b e =
 let scroll_to_id id =
   match id.Ident.id_origin with
     | Ident.User loc ->
-        let (f,l,b,e) = Loc.extract loc in
+        let (f,l,b,e) = Loc.get loc in
         if f <> !current_file then
           begin
             source_view#source_buffer#set_text (source_text f);
@@ -1799,9 +1799,10 @@ let scroll_to_id id =
         set_current_file ""
 
 let color_label = function
-  | _, Some loc when (fst loc).Lexing.pos_fname = !current_file ->
-      let _, l, b, e = Loc.extract loc in
-      color_loc source_view l b e
+  | _, Some loc ->
+      let f, l, b, e = Loc.get loc in
+      if f = !current_file then
+        color_loc source_view l b e
   | _ ->
       ()
 
@@ -1994,7 +1995,7 @@ let remove_transf t =
   let g = t.Model.parent_goal in
   Hashtbl.remove g.Model.transformations "split" (* hack !! *);
   Helpers.check_goal_proved g
-  
+
 
 let confirm_remove_row r =
   let row = filter_model#get_iter r in

src/parser/lexer.mll

@@ -136,7 +136,7 @@
     let n = String.length s in
     if n > 0 && s.[0] = '+' then String.sub s 1 (n-1) else s
 
-  let loc lb = (lexeme_start_p lb, lexeme_end_p lb)
+  let loc lb = Loc.extract (lexeme_start_p lb, lexeme_end_p lb)
 
 }
 

src/parser/parser.pre.mly

@@ -54,20 +54,24 @@
   open Parsing
 
   let loc () = (symbol_start_pos (), symbol_end_pos ())
+  let floc () = Loc.extract (loc ())
+
   let loc_i i = (rhs_start_pos i, rhs_end_pos i)
+  let floc_i i = Loc.extract (loc_i i)
   let loc_ij i j = (rhs_start_pos i, rhs_end_pos j)
+  let floc_ij i j = Loc.extract (loc_ij i j)
 
   let mk_ppl loc d = { pp_loc = loc; pp_desc = d }
-  let mk_pp d = mk_ppl (loc ()) d
-  let mk_pp_i i d = mk_ppl (loc_i i) d
+  let mk_pp d = mk_ppl (floc ()) d
+  let mk_pp_i i d = mk_ppl (floc_i i) d
 
-  let mk_pat p = { pat_loc = loc (); pat_desc = p }
+  let mk_pat p = { pat_loc = floc (); pat_desc = p }
 
   let infix_ppl loc a i b = mk_ppl loc (PPbinop (a, i, b))
-  let infix_pp a i b = infix_ppl (loc ()) a i b
+  let infix_pp a i b = infix_ppl (floc ()) a i b
 
   let prefix_ppl loc p a = mk_ppl loc (PPunop (p, a))
-  let prefix_pp p a = prefix_ppl (loc ()) p a
+  let prefix_pp p a = prefix_ppl (floc ()) p a
 
   let infix  s = "infix "  ^ s
   let prefix s = "prefix " ^ s
@@ -77,37 +81,26 @@
 
   let add_lab id l = { id with id_lab = l }
 
-  let user_loc fname lnum bol cnum1 cnum2 =
-    let pos = {
-      Lexing.pos_fname = fname;
-      Lexing.pos_lnum = lnum;
-      Lexing.pos_bol = bol;
-      Lexing.pos_cnum = cnum1 }
-    in
-    pos, { pos with Lexing.pos_cnum = cnum2 }
-
   let () = Exn_printer.register
     (fun fmt exn -> match exn with
       | Parsing.Parse_error -> Format.fprintf fmt "syntax error"
       | _ -> raise exn
     )
 
-  let mk_expr d = { expr_loc = loc (); expr_desc = d }
-  let mk_expr_i i d = { expr_loc = loc_i i; expr_desc = d }
+  let mk_expr d = { expr_loc = floc (); expr_desc = d }
+  let mk_expr_i i d = { expr_loc = floc_i i; expr_desc = d }
 
   let cast_body c ((p,e,q) as t) = match c with
     | None -> t
     | Some pt -> p, { e with expr_desc = Ecast (e, pt) }, q
 
-  let join (b,_) (_,e) = (b,e)
-
   let rec mk_apply f = function
     | [] ->
 	assert false
     | [a] ->
 	Eapply (f, a)
     | a :: l ->
-	let loc = join f.expr_loc a.expr_loc in
+	let loc = Loc.join f.expr_loc a.expr_loc in
 	mk_apply { expr_loc = loc; expr_desc = Eapply (f, a) } l
 
   let mk_apply_id id =
@@ -117,27 +110,27 @@
     mk_apply e
 
   let mk_misfix2 op e1 e2 =
-    let id = { id = misfix op; id_lab = []; id_loc = loc_i 2 } in
+    let id = { id = misfix op; id_lab = []; id_loc = floc_i 2 } in
     mk_expr (mk_apply_id id [e1; e2])
 
   let mk_misfix3 op e1 e2 e3 =
-    let id = { id = misfix op; id_lab = []; id_loc = loc_i 2 } in
+    let id = { id = misfix op; id_lab = []; id_loc = floc_i 2 } in
     mk_expr (mk_apply_id id [e1; e2; e3])
 
   let mk_infix e1 op e2 =
-    let id = { id = infix op; id_lab = []; id_loc = loc_i 2 } in
+    let id = { id = infix op; id_lab = []; id_loc = floc_i 2 } in
     mk_expr (mk_apply_id id [e1; e2])
 
   let mk_prefix op e1 =
-    let id = { id = prefix op; id_lab = []; id_loc = loc_i 1 } in
+    let id = { id = prefix op; id_lab = []; id_loc = floc_i 1 } in
     mk_expr (mk_apply_id id [e1])
 
-  let exit_exn () = Qident { id = "%Exit"; id_lab = []; id_loc = loc () }
-  let id_anonymous () = { id = "_"; id_lab = []; id_loc = loc () }
-  let id_unit () = { id = "unit"; id_lab = []; id_loc = loc () }
+  let exit_exn () = Qident { id = "%Exit"; id_lab = []; id_loc = floc () }
+  let id_anonymous () = { id = "_"; id_lab = []; id_loc = floc () }
+  let id_unit () = { id = "unit"; id_lab = []; id_loc = floc () }
   let ty_unit () = Tpure (PPTtyapp ([], Qident (id_unit ())))
 
-  let id_lt_nat () = Qident { id = "lt_nat"; id_lab = []; id_loc = loc () }
+  let id_lt_nat () = Qident { id = "lt_nat"; id_lab = []; id_loc = floc () }
 
   let empty_effect = { pe_reads = []; pe_writes = []; pe_raises = [] }
 
@@ -272,7 +265,7 @@ new_decl:
    { let env = ref_get env_ref in let lenv = ref_get lenv_ref in
      ref_set uc_ref (Typing.add_decl env lenv (ref_get uc_ref) $1) }
 | namespace_head namespace_import namespace_name list0_decl END
-   { ref_set uc_ref (Typing.close_namespace (loc ()) $2 $3 (ref_get uc_ref)) }
+   { ref_set uc_ref (Typing.close_namespace (floc ()) $2 $3 (ref_get uc_ref)) }
 ;
 
 namespace_head:
@@ -300,19 +293,19 @@ decl:
 | INDUCTIVE list1_inductive_decl
     { IndDecl $2 }
 | AXIOM ident labels COLON lexpr
-    { PropDecl (loc (), Kaxiom, add_lab $2 $3, $5) }
+    { PropDecl (floc (), Kaxiom, add_lab $2 $3, $5) }
 | LEMMA ident labels COLON lexpr
-    { PropDecl (loc (), Klemma, add_lab $2 $3, $5) }
+    { PropDecl (floc (), Klemma, add_lab $2 $3, $5) }
 | GOAL ident labels COLON lexpr
-    { PropDecl (loc (), Kgoal, add_lab $2 $3, $5) }
+    { PropDecl (floc (), Kgoal, add_lab $2 $3, $5) }
 | USE use
-    { UseClone (loc (), $2, None) }
+    { UseClone (floc (), $2, None) }
 | CLONE use clone_subst
-    { UseClone (loc (), $2, Some $3) }
+    { UseClone (floc (), $2, Some $3) }
 | META ident list1_meta_arg_sep_comma
-    { Meta (loc (), $2, $3) }
+    { Meta (floc (), $2, $3) }
 | META STRING list1_meta_arg_sep_comma
-    { Meta (loc (), mk_id $2 (loc_i 2), $3) }
+    { Meta (floc (), mk_id $2 (floc_i 2), $3) }
 ;
 
 /* Use and clone */
@@ -379,7 +372,7 @@ list1_type_decl:
 
 type_decl:
 | lident labels type_args typedefn
-  { { td_loc = loc (); td_ident = add_lab $1 $2;
+  { { td_loc = floc (); td_ident = add_lab $1 $2;
       td_params = $3; td_def = $4 } }
 ;
 
@@ -407,7 +400,7 @@ list1_record_field:
 
 record_field:
 | opt_mutable lident labels COLON primitive_type 
-   { loc (), $1, add_lab $2 $3, $5 }
+   { floc (), $1, add_lab $2 $3, $5 }
 ;
 
 typecases:
@@ -416,7 +409,7 @@ typecases:
 ;
 
 typecase:
-| uident labels params   { (loc (), add_lab $1 $2, $3) }
+| uident labels params   { (floc (), add_lab $1 $2, $3) }
 ;
 
 /* Logic declarations */
@@ -428,7 +421,7 @@ list1_logic_decl:
 
 logic_decl:
 | lident_rich labels params logic_type_option logic_def_option
-  { { ld_loc = loc (); ld_ident = add_lab $1 $2;
+  { { ld_loc = floc (); ld_ident = add_lab $1 $2;
       ld_params = $3; ld_type = $4; ld_def = $5 } }
 ;
 
@@ -451,7 +444,7 @@ list1_inductive_decl:
 
 inductive_decl:
 | lident_rich labels params inddefn
-  { { in_loc = loc (); in_ident = add_lab $1 $2;
+  { { in_loc = floc (); in_ident = add_lab $1 $2;
       in_params = $3; in_def = $4 } }
 ;
 
@@ -466,7 +459,7 @@ indcases:
 ;
 
 indcase:
-| ident labels COLON lexpr { (loc (), add_lab $1 $2, $4) }
+| ident labels COLON lexpr { (floc (), add_lab $1 $2, $4) }
 ;
 
 /* Type expressions */
@@ -531,19 +524,19 @@ lexpr:
 | NOT lexpr
    { prefix_pp PPnot $2 }
 | lexpr EQUAL lexpr
-   { mk_pp (PPinfix ($1, mk_id (infix "=") (loc_i 2), $3)) }
+   { mk_pp (PPinfix ($1, mk_id (infix "=") (floc_i 2), $3)) }
 | lexpr LTGT lexpr
-   { prefix_pp PPnot (mk_pp (PPinfix ($1, mk_id (infix "=") (loc_i 2), $3))) }
+   { prefix_pp PPnot (mk_pp (PPinfix ($1, mk_id (infix "=") (floc_i 2), $3))) }
 | lexpr OP1 lexpr
-   { mk_pp (PPinfix ($1, mk_id (infix $2) (loc_i 2), $3)) }
+   { mk_pp (PPinfix ($1, mk_id (infix $2) (floc_i 2), $3)) }
 | lexpr OP2 lexpr
-   { mk_pp (PPinfix ($1, mk_id (infix $2) (loc_i 2), $3)) }
+   { mk_pp (PPinfix ($1, mk_id (infix $2) (floc_i 2), $3)) }
 | lexpr OP3 lexpr
-   { mk_pp (PPinfix ($1, mk_id (infix $2) (loc_i 2), $3)) }
+   { mk_pp (PPinfix ($1, mk_id (infix $2) (floc_i 2), $3)) }
 | lexpr OP4 lexpr
-   { mk_pp (PPinfix ($1, mk_id (infix $2) (loc_i 2), $3)) }
+   { mk_pp (PPinfix ($1, mk_id (infix $2) (floc_i 2), $3)) }
 | any_op lexpr %prec prefix_op
-   { mk_pp (PPapp (Qident (mk_id (prefix $1) (loc_i 2)), [$2])) }
+   { mk_pp (PPapp (Qident (mk_id (prefix $1) (floc_i 2)), [$2])) }
 | qualid list1_lexpr_arg
    { mk_pp (PPapp ($1, $2)) }
 | IF lexpr THEN lexpr ELSE lexpr
@@ -599,7 +592,7 @@ lexpr_arg:
 | FALSE
    { mk_pp PPfalse }
 | OPPREF lexpr_arg
-   { mk_pp (PPapp (Qident (mk_id (prefix $1) (loc_i 2)), [$2])) }
+   { mk_pp (PPapp (Qident (mk_id (prefix $1) (floc_i 2)), [$2])) }
 | lexpr_sub
    { $1 }
 ;
@@ -608,7 +601,7 @@ lexpr_dot:
 | lqualid_rich
    { mk_pp (PPvar $1) }
 | OPPREF lexpr_dot
-   { mk_pp (PPapp (Qident (mk_id (prefix $1) (loc_i 2)), [$2])) }
+   { mk_pp (PPapp (Qident (mk_id (prefix $1) (floc_i 2)), [$2])) }
 | lexpr_sub
    { $1 }
 ;
@@ -627,10 +620,10 @@ lexpr_sub:
 | LEFTREC lexpr_arg WITH list1_field_value opt_semicolon RIGHTREC
    { mk_pp (PPupdate ($2, List.rev $4)) }
 | lexpr_arg LEFTSQ lexpr RIGHTSQ
-   { mk_pp (PPapp (Qident (mk_id (misfix "[]") (loc ())), [$1; $3])) }
+   { mk_pp (PPapp (Qident (mk_id (misfix "[]") (floc ())), [$1; $3])) }
 | lexpr_arg LEFTSQ lexpr OP1 lexpr RIGHTSQ
    { let op = "[" ^ $4 ^ "]" in
-     mk_pp (PPapp (Qident (mk_id (misfix op) (loc ())), [$1; $3; $5])) }
+     mk_pp (PPapp (Qident (mk_id (misfix op) (floc ())), [$1; $3; $5])) }
 ;
 
 quant:
@@ -797,22 +790,22 @@ lident_rich:
 | lident
     { $1 }
 | LEFTPAR lident_op RIGHTPAR
-    { mk_id (infix $2) (loc ()) }
+    { mk_id (infix $2) (floc ()) }
 | LEFTPAR_STAR_RIGHTPAR
-    { mk_id (infix "*") (loc ()) }
+    { mk_id (infix "*") (floc ()) }
 | LEFTPAR lident_op UNDERSCORE RIGHTPAR
-    { mk_id (prefix $2) (loc ()) }
+    { mk_id (prefix $2) (floc ()) }
 | LEFTPAR OPPREF RIGHTPAR
-    { mk_id (prefix $2) (loc ()) }
+    { mk_id (prefix $2) (floc ()) }
 | LEFTPAR LEFTSQ RIGHTSQ RIGHTPAR
-    { mk_id (misfix "[]") (loc ()) }
+    { mk_id (misfix "[]") (floc ()) }
 | LEFTPAR LEFTSQ OP1 RIGHTSQ RIGHTPAR
-    { mk_id (misfix ("[" ^ $3 ^ "]")) (loc ()) }
+    { mk_id (misfix ("[" ^ $3 ^ "]")) (floc ()) }
 ;
 
 lident:
-| LIDENT { mk_id $1 (loc ()) }
-| MODEL  { mk_id "model" (loc ()) }
+| LIDENT { mk_id $1 (floc ()) }
+| MODEL  { mk_id "model" (floc ()) }
 ;
 
 lident_op:
@@ -831,7 +824,7 @@ any_op:
 ;
 
 uident:
-| UIDENT { mk_id $1 (loc ()) }
+| UIDENT { mk_id $1 (floc ()) }
 ;
 
 lq_lident:
@@ -878,10 +871,10 @@ label:
 | STRING
    { Ident.label $1 }
 | STRING BACKQUOTE INTEGER BACKQUOTE INTEGER
-         BACKQUOTE INTEGER BACKQUOTE INTEGER BACKQUOTE STRING
-   { let loc = user_loc $11 (int_of_string $3) (int_of_string $5)
-                            (int_of_string $7) (int_of_string $9) in
-     Ident.label ~loc $1 }
+         BACKQUOTE INTEGER BACKQUOTE STRING
+   { let loc = Loc.user_position $9 (int_of_string $3) (int_of_string $5)
+                            (int_of_string $7) 
+     in Ident.label ~loc $1 }
 ;