Introduce the Lambda.scoped_location type

lambda/debuginfo.ml

@@ -17,6 +17,85 @@ open! Int_replace_polymorphic_compare
 open Lexing
 open Location
 
+module Scoped_location = struct
+  type scope_item =
+    | Sc_anonymous_function
+    | Sc_value_definition of string
+    | Sc_module_definition of string
+    | Sc_class_definition of string
+    | Sc_method_definition of string
+
+  type scopes = scope_item list
+
+  let add_parens_if_symbolic = function
+    | "" -> ""
+    | s ->
+       match s.[0] with
+       | 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> s
+       | _ -> "(" ^ s ^ ")"
+
+  let string_of_scope_item = function
+    | Sc_anonymous_function ->
+       "(fun)"
+    | Sc_value_definition name
+    | Sc_module_definition name
+    | Sc_class_definition name
+    | Sc_method_definition name ->
+       add_parens_if_symbolic name
+
+  let string_of_scopes scopes =
+    let dot acc =
+      match acc with
+      | [] -> []
+      | acc -> "." :: acc in
+    let rec to_strings acc = function
+      | [] -> acc
+        (* Collapse nested anonymous function scopes *)
+      | Sc_anonymous_function :: ((Sc_anonymous_function :: _) as rest) ->
+        to_strings acc rest
+        (* Use class#meth syntax for classes *)
+      | (Sc_method_definition _ as meth) ::
+        (Sc_class_definition _ as cls) :: rest ->
+        to_strings (string_of_scope_item cls :: "#" ::
+                      string_of_scope_item meth :: dot acc) rest
+      | s :: rest ->
+        to_strings (string_of_scope_item s :: dot acc) rest in
+    match scopes with
+    | [] -> "<unknown>"
+    | scopes -> String.concat "" (to_strings [] scopes)
+
+  let enter_anonymous_function ~scopes =
+    Sc_anonymous_function :: scopes
+  let enter_value_definition ~scopes id =
+    Sc_value_definition (Ident.name id) :: scopes
+  let enter_module_definition ~scopes id =
+    Sc_module_definition (Ident.name id) :: scopes
+  let enter_class_definition ~scopes id =
+    Sc_class_definition (Ident.name id) :: scopes
+  let enter_method_definition ~scopes (m : Asttypes.label) =
+    Sc_method_definition m :: scopes
+
+  type t =
+    | Loc_unknown
+    | Loc_known of
+        { loc : Location.t;
+          scopes : scopes; }
+
+  let of_location ~scopes loc =
+    if Location.is_none loc then
+      Loc_unknown
+    else
+      Loc_known { loc; scopes }
+
+  let to_location = function
+    | Loc_unknown -> Location.none
+    | Loc_known { loc; _ } -> loc
+
+  let string_of_scoped_location = function
+    | Loc_unknown -> "??"
+    | Loc_known { loc = _; scopes } -> string_of_scopes scopes
+end
+
 type item = {
   dinfo_file: string;
   dinfo_line: int;

lambda/debuginfo.mli

@@ -13,6 +13,35 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module Scoped_location : sig
+  type scope_item =
+    | Sc_anonymous_function
+    | Sc_value_definition of string
+    | Sc_module_definition of string
+    | Sc_class_definition of string
+    | Sc_method_definition of string
+
+  type scopes = scope_item list
+  val string_of_scope_item : scope_item -> string
+  val string_of_scopes : scopes -> string
+
+  val enter_anonymous_function : scopes:scopes -> scopes
+  val enter_value_definition : scopes:scopes -> Ident.t -> scopes
+  val enter_module_definition : scopes:scopes -> Ident.t -> scopes
+  val enter_class_definition : scopes:scopes -> Ident.t -> scopes
+  val enter_method_definition : scopes:scopes -> Asttypes.label -> scopes
+
+  type t =
+    | Loc_unknown
+    | Loc_known of
+        { loc : Location.t;
+          scopes : scopes; }
+
+  val of_location : scopes:scopes -> Location.t -> t
+  val to_location : t -> Location.t
+  val string_of_scoped_location : t -> string
+end
+
 type item = private {
   dinfo_file: string;
   dinfo_line: int;

lambda/lambda.ml

@@ -275,6 +275,8 @@ type function_attribute = {
   stub: bool;
 }
 
+type scoped_location = Debuginfo.Scoped_location.t
+
 type lambda =
     Lvar of Ident.t
   | Lconst of structured_constant

lambda/lambda.mli

@@ -255,6 +255,8 @@ type function_attribute = {
   stub: bool;
 }
 
+type scoped_location = Debuginfo.Scoped_location.t
+
 type lambda =
     Lvar of Ident.t
   | Lconst of structured_constant

otherlibs/dynlink/Makefile

@@ -83,6 +83,7 @@ COMPILERLIBS_SOURCES=\
   utils/terminfo.ml \
   utils/warnings.ml \
   utils/load_path.ml \
+  utils/int_replace_polymorphic_compare.ml \
   parsing/location.ml \
   parsing/longident.ml \
   parsing/docstrings.ml \
@@ -103,6 +104,7 @@ COMPILERLIBS_SOURCES=\
   file_formats/cmi_format.ml \
   typing/persistent_env.ml \
   typing/env.ml \
+  lambda/debuginfo.ml \
   lambda/lambda.ml \
   lambda/runtimedef.ml \
   bytecomp/instruct.ml \

parsing/location.ml

@@ -24,6 +24,7 @@ let in_file name =
 ;;
 
 let none = in_file "_none_";;
+let is_none l = (l = none);;
 
 let curr lexbuf = {
   loc_start = lexbuf.lex_start_p;

parsing/location.mli

@@ -38,6 +38,9 @@ type t = Warnings.loc = {
 val none : t
 (** An arbitrary value of type [t]; describes an empty ghost range. *)
 
+val is_none : t -> bool
+(** True for [Location.none], false any other location *)
+
 val in_file : string -> t
 (** Return an empty ghost range located in a given file. *)