Add %loc_* primitives and corresponding values in Pervasives

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14571 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

bytecomp/lambda.ml

@@ -21,11 +21,19 @@ type compile_time_constant =
   | Ostype_win32
   | Ostype_cygwin
 
+type loc_kind =
+  | Loc_FILE
+  | Loc_LINE
+  | Loc_MODULE
+  | Loc_LOC
+  | Loc_POS
+
 type primitive =
     Pidentity
   | Pignore
   | Prevapply of Location.t
   | Pdirapply of Location.t
+  | Ploc of loc_kind
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
@@ -203,7 +211,7 @@ let lambda_unit = Lconst const_unit
 
 exception Not_simple
 
-let max_raw = 32 
+let max_raw = 32
 
 let make_key e =
   let count = ref 0
@@ -247,7 +255,7 @@ let make_key e =
     | Ltrywith (e1,x,e2) ->
         Ltrywith (tr_rec env e1,x,tr_rec env e2)
     | Lifthenelse (cond,ifso,ifnot) ->
-        Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) 
+        Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot)
     | Lsequence (e1,e2) ->
         Lsequence (tr_rec env e1,tr_rec env e2)
     | Lassign (x,e) ->
@@ -258,7 +266,7 @@ let make_key e =
         Levent (tr_rec env e,evt)
     | Lifused (id,e) -> Lifused (id,tr_rec env e)
     | Lletrec _|Lfunction _
-    | Lfor _ | Lwhile _  -> 
+    | Lfor _ | Lwhile _  ->
         raise Not_simple
 
   and tr_recs env es = List.map (tr_rec env) es
@@ -317,7 +325,7 @@ let iter f = function
       f arg;
       List.iter (fun (key, case) -> f case) sw.sw_consts;
       List.iter (fun (key, case) -> f case) sw.sw_blocks;
-      iter_opt f sw.sw_failaction 
+      iter_opt f sw.sw_failaction
   | Lstringswitch (arg,cases,default) ->
       f arg ;
       List.iter (fun (_,act) -> f act) cases ;
@@ -422,7 +430,7 @@ let rec transl_normal_path = function
 (* Translation of value identifiers *)
 
 let transl_path ?(loc=Location.none) env path =
-  transl_normal_path (Env.normalize_path (Some loc) env path) 
+  transl_normal_path (Env.normalize_path (Some loc) env path)
 
 (* Compile a sequence of expressions *)
 
@@ -498,3 +506,26 @@ let raise_kind = function
   | Raise_regular -> "raise"
   | Raise_reraise -> "reraise"
   | Raise_notrace -> "raise_notrace"
+
+let lam_of_loc kind loc =
+  let loc_start = loc.Location.loc_start in
+  let (file, lnum, cnum) = Location.get_pos_info loc_start in
+  let enum = loc.Location.loc_end.Lexing.pos_cnum -
+      loc_start.Lexing.pos_cnum + cnum in
+  match kind with
+  | Loc_POS ->
+    Lconst (Const_block (0, [
+          Const_immstring file;
+          Const_base (Const_int lnum);
+          Const_base (Const_int cnum);
+          Const_base (Const_int enum);
+        ]))
+  | Loc_FILE -> Lconst (Const_immstring file)
+  | Loc_MODULE -> Lconst (Const_immstring
+                      (String.capitalize
+                         (Filename.chop_extension (Filename.basename file))))
+  | Loc_LOC ->
+    let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
+        file lnum cnum enum in
+    Lconst (Const_immstring loc)
+  | Loc_LINE -> Lconst (Const_base (Const_int lnum))

bytecomp/lambda.mli

@@ -21,11 +21,19 @@ type compile_time_constant =
   | Ostype_win32
   | Ostype_cygwin
 
+type loc_kind =
+  | Loc_FILE
+  | Loc_LINE
+  | Loc_MODULE
+  | Loc_LOC
+  | Loc_POS
+
 type primitive =
     Pidentity
   | Pignore
   | Prevapply of Location.t
   | Pdirapply of Location.t
+  | Ploc of loc_kind
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
@@ -245,3 +253,4 @@ val is_guarded: lambda -> bool
 val patch_guarded : lambda -> lambda -> lambda
 
 val raise_kind: raise_kind -> string
+val lam_of_loc : loc_kind -> Location.t -> lambda

bytecomp/printlambda.ml

@@ -87,11 +87,19 @@ let record_rep ppf r =
   | Record_float -> fprintf ppf "float"
 ;;
 
+let string_of_loc_kind = function
+  | Loc_FILE -> "loc_FILE"
+  | Loc_LINE -> "loc_LINE"
+  | Loc_MODULE -> "loc_MODULE"
+  | Loc_POS -> "loc_POS"
+  | Loc_LOC -> "loc_LOC"
+
 let primitive ppf = function
   | Pidentity -> fprintf ppf "id"
   | Pignore -> fprintf ppf "ignore"
   | Prevapply _ -> fprintf ppf "revapply"
   | Pdirapply _ -> fprintf ppf "dirapply"
+  | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind)
   | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
   | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag

bytecomp/translcore.ml

@@ -325,6 +325,11 @@ let find_primitive loc prim_name =
   match prim_name with
       "%revapply" -> Prevapply loc
     | "%apply" -> Pdirapply loc
+    | "%loc_LOC" -> Ploc Loc_LOC
+    | "%loc_FILE" -> Ploc Loc_FILE
+    | "%loc_LINE" -> Ploc Loc_LINE
+    | "%loc_POS" -> Ploc Loc_POS
+    | "%loc_MODULE" -> Ploc Loc_MODULE
     | name -> Hashtbl.find primitives_table name
 
 let transl_prim loc prim args =
@@ -404,10 +409,20 @@ let transl_primitive loc p =
     with Not_found ->
       Pccall p in
   match prim with
-    Plazyforce ->
+  | Plazyforce ->
       let parm = Ident.create "prim" in
       Lfunction(Curried, [parm],
                 Matching.inline_lazy_force (Lvar parm) Location.none)
+  | Ploc kind ->
+    let lam = lam_of_loc kind loc in
+    begin match p.prim_arity with
+      | 0 -> lam
+      | 1 -> (* TODO: we should issue a warning ? *)
+        let param = Ident.create "prim" in
+        Lfunction(Curried, [param],
+          Lprim(Pmakeblock(0, Immutable), [lam; Lvar param]))
+      | _ -> assert false
+    end
   | _ ->
       let rec make_params n =
         if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
@@ -694,6 +709,12 @@ and transl_exp0 e =
                   k
             in
             wrap0 (Lprim(Praise k, [event_after arg1 targ]))
+        | (Ploc kind, []) ->
+          lam_of_loc kind e.exp_loc
+        | (Ploc kind, [arg1]) ->
+          let lam = lam_of_loc kind arg1.exp_loc in
+          Lprim(Pmakeblock(0, Immutable), lam :: argl)
+        | (Ploc _, _) -> assert false
         | (_, _) ->
             begin match (prim, argl) with
             | (Plazyforce, [a]) ->

otherlibs/threads/pervasives.ml

@@ -40,6 +40,20 @@ exception Exit
 external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
 external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
 
+(* Debugging *)
+
+external __LOC__ : string = "%loc_LOC"
+external __FILE__ : string = "%loc_FILE"
+external __LINE__ : int = "%loc_LINE"
+external __MODULE__ : string = "%loc_MODULE"
+external __POS__ : string * int * int * int = "%loc_POS"
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE"
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE"
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+
 (* Comparisons *)
 
 external (=) : 'a -> 'a -> bool = "%equal"

stdlib/pervasives.ml

@@ -37,6 +37,20 @@ exception Exit
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
 external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
 
+(* Debugging *)
+
+external __LOC__ : string = "%loc_LOC"
+external __FILE__ : string = "%loc_FILE"
+external __LINE__ : int = "%loc_LINE"
+external __MODULE__ : string = "%loc_MODULE"
+external __POS__ : string * int * int * int = "%loc_POS"
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE"
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE"
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
+
 (* Comparisons *)
 
 external ( = ) : 'a -> 'a -> bool = "%equal"

stdlib/pervasives.mli

@@ -140,6 +140,19 @@ external ( || ) : bool -> bool -> bool = "%sequor"
 external ( or ) : bool -> bool -> bool = "%sequor"
 (** @deprecated {!Pervasives.( || )} should be used instead.*)
 
+(** {6 Debugging} *)
+
+external __LOC__ : string = "%loc_LOC"
+external __FILE__ : string = "%loc_FILE"
+external __LINE__ : int = "%loc_LINE"
+external __MODULE__ : string = "%loc_MODULE"
+external __POS__ : string * int * int * int = "%loc_POS"
+
+external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
+external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE"
+external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
+external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE"
+external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
 
 (** {6 Composition operators} *)
 

typing/typedecl.ml

@@ -1074,9 +1074,9 @@ let transl_value_decl env loc valdecl =
         val_attributes = valdecl.pval_attributes }
   | decl ->
       let arity = Ctype.arity ty in
-      if arity = 0 then
-        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
       let prim = Primitive.parse_declaration arity decl in
+      if arity = 0 && prim.prim_name.[0] <> '%' then
+        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
       if !Clflags.native_code
       && prim.prim_arity > 5
       && prim.prim_native_name = ""