Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Annotated Asttypes.constant's string with content location.

master
Drup 2019-07-22 18:21:26 +02:00
parent abc53d1a6e
commit 9c8b63f4ce
15 changed files with 37 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
bytecomp/symtable.ml
View File

@ -154,10 +154,11 @@ let init () =
try List.assoc name Predef.builtin_values
with Not_found -> fatal_error "Symtable.init" in
let c = slot_for_setglobal id in
let cst = Const_block(Obj.object_tag,
[Const_base(Const_string (name, None));
Const_base(Const_int (-i-1))
])
let cst = Const_block
(Obj.object_tag,
[Const_base(Const_string (name, Location.none,None));
Const_base(Const_int (-i-1))
])
in
literal_table := (c, cst) :: !literal_table)
Runtimedef.builtin_exceptions;
@ -216,7 +217,7 @@ let patch_object buff patchlist =
let rec transl_const = function
Const_base(Const_int i) -> Obj.repr i
| Const_base(Const_char c) -> Obj.repr c
| Const_base(Const_string (s, _)) -> Obj.repr s
| Const_base(Const_string (s, _, _)) -> Obj.repr s
| Const_base(Const_float f) -> Obj.repr (float_of_string f)
| Const_base(Const_int32 i) -> Obj.repr i
| Const_base(Const_int64 i) -> Obj.repr i

4
lambda/matching.ml
View File

@ -2613,7 +2613,7 @@ let combine_constant loc arg cst partial ctx def
List.map
(fun (c, act) ->
match c with
| Const_string (s, _) -> (s, act)
| Const_string (s, _, _) -> (s, act)
| _ -> assert false)
const_lambda_list
in
@ -3326,7 +3326,7 @@ let partial_function loc () =
Lconst
(Const_block
( 0,
[ Const_base (Const_string (fname, None));
[ Const_base (Const_string (fname, loc, None));
Const_base (Const_int line);
Const_base (Const_int char)
] ))

2
lambda/printlambda.ml
View File

@ -23,7 +23,7 @@ open Lambda
let rec struct_const ppf = function
| Const_base(Const_int n) -> fprintf ppf "%i" n
| Const_base(Const_char c) -> fprintf ppf "%C" c
| Const_base(Const_string (s, _)) -> fprintf ppf "%S" s
| Const_base(Const_string (s, _, _)) -> fprintf ppf "%S" s
| Const_immstring s -> fprintf ppf "#%S" s
| Const_base(Const_float f) -> fprintf ppf "%s" f
| Const_base(Const_int32 n) -> fprintf ppf "%lil" n

9
lambda/translcore.ml
View File

@ -61,7 +61,7 @@ let transl_extension_constructor env path ext =
match ext.ext_kind with
Text_decl _ ->
Lprim (Pmakeblock (Obj.object_tag, Immutable, None),
[Lconst (Const_base (Const_string (name, None)));
[Lconst (Const_base (Const_string (name, loc, None)));
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
loc)
| Text_rebind(path, _lid) ->
@ -174,16 +174,17 @@ let assert_failed exp =
transl_extension_path Location.none
Env.initial_safe_string Predef.path_assert_failure
in
let loc = exp.exp_loc in
let (fname, line, char) =
Location.get_pos_info exp.exp_loc.Location.loc_start
Location.get_pos_info loc.Location.loc_start
in
Lprim(Praise Raise_regular, [event_after exp
(Lprim(Pmakeblock(0, Immutable, None),
[slot;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
[Const_base(Const_string (fname, loc, None));
Const_base(Const_int line);
Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc)
Const_base(Const_int char)]))], loc))], loc)
;;
let rec cut n l =

8
lambda/translmod.ml
View File

@ -214,7 +214,7 @@ let mod_prim = Lambda.transl_prim "CamlinternalMod"
let undefined_location loc =
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
[Const_base(Const_string (fname, loc, None));
Const_base(Const_int line);
Const_base(Const_int char)]))
@ -1361,7 +1361,8 @@ let toploop_getvalue id =
ap_func=Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [], Location.none)],
Location.none);
ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))];
ap_args=[Lconst(Const_base(
Const_string (toplevel_name id, Location.none,None)))];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
@ -1371,7 +1372,8 @@ let toploop_setvalue id lam =
ap_func=Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [], Location.none)],
Location.none);
ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)));
ap_args=[Lconst(Const_base(
Const_string (toplevel_name id, Location.none, None)));
lam];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}

2
middle_end/closure/closure.ml
View File

@ -882,7 +882,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
str (Uconst_float_array (List.map float_of_string sl))
| Const_immstring s ->
str (Uconst_string s)
| Const_base (Const_string (s, _)) ->
| Const_base (Const_string (s, _, _)) ->
(* Strings (even literal ones) must be assumed to be mutable...
except when OCaml has been configured with
-safe-string. Passing -safe-string at compilation

2
middle_end/flambda/closure_conversion.ml
View File

@ -115,7 +115,7 @@ let rec declare_const t (const : Lambda.structured_constant)
match const with
| Const_base (Const_int c) -> (Const (Int c), Names.const_int)
| Const_base (Const_char c) -> (Const (Char c), Names.const_char)
| Const_base (Const_string (s, _)) ->
| Const_base (Const_string (s, _, _)) ->
let const, name =
if Config.safe_string then
(Flambda.Allocated_const (Immutable_string s),

2
parsing/asttypes.mli
View File

@ -23,7 +23,7 @@
type constant =
Const_int of int
| Const_char of char
| Const_string of string * string option
| Const_string of string * Location.t * string option
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64

2
testsuite/tools/expect_test.ml
View File

@ -66,7 +66,7 @@ let match_expect_extension (ext : Parsetree.extension) =
in
let string_constant (e : Parsetree.expression) =
match e.pexp_desc with
| Pexp_constant (Pconst_string (str, Some tag)) ->
| Pexp_constant (Pconst_string (str, _, Some tag)) ->
{ str; tag }
| _ -> invalid_payload ()
in

2
tools/dumpobj.ml
View File

@ -86,7 +86,7 @@ let print_float f =
let rec print_struct_const = function
Const_base(Const_int i) -> printf "%d" i
| Const_base(Const_float f) -> print_float f
| Const_base(Const_string (s, _)) -> printf "%S" s
| Const_base(Const_string (s, _, _)) -> printf "%S" s
| Const_immstring s -> printf "%S" s
| Const_base(Const_char c) -> printf "%C" c
| Const_base(Const_int32 i) -> printf "%ldl" i

10
typing/parmatch.ml
View File

@ -393,11 +393,11 @@ let const_compare x y =
match x,y with
| Const_float f1, Const_float f2 ->
Stdlib.compare (float_of_string f1) (float_of_string f2)
| Const_string (s1, _), Const_string (s2, _) ->
| Const_string (s1, _, _), Const_string (s2, _, _) ->
String.compare s1 s2
| (Const_int _
|Const_char _
|Const_string (_, _)
|Const_string (_, _, _)
|Const_float _
|Const_int32 _
|Const_int64 _
@ -1192,9 +1192,11 @@ let build_other ext env =
0n Nativeint.succ d env
| Constant Const_string _ ->
build_other_constant
(function Constant(Const_string (s, _)) -> String.length s
(function Constant(Const_string (s, _, _)) -> String.length s
| _ -> assert false)
(function i -> Tpat_constant(Const_string(String.make i '*', None)))
(function i ->
Tpat_constant
(Const_string(String.make i '*',Location.none,None)))
0 succ d env
| Constant Const_float _ ->
build_other_constant

2
typing/printpat.ml
View File

@ -27,7 +27,7 @@ let is_cons = function
let pretty_const c = match c with
| Const_int i -> Printf.sprintf "%d" i
| Const_char c -> Printf.sprintf "%C" c
| Const_string (s, _) -> Printf.sprintf "%S" s
| Const_string (s, _, _) -> Printf.sprintf "%S" s
| Const_float f -> Printf.sprintf "%s" f
| Const_int32 i -> Printf.sprintf "%ldl" i
| Const_int64 i -> Printf.sprintf "%LdL" i

7
typing/printtyped.ml
View File

@ -61,9 +61,10 @@ let fmt_constant f x =
match x with
| Const_int (i) -> fprintf f "Const_int %d" i;
| Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
| Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
| Const_string (s, Some delim) ->
fprintf f "Const_string (%S,Some %S)" s delim;
| Const_string (s, strloc, None) ->
fprintf f "Const_string(%S,%a,None)" s fmt_location strloc;
| Const_string (s, strloc, Some delim) ->
fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim;
| Const_float (s) -> fprintf f "Const_float %s" s;
| Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
| Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;

2
typing/typecore.ml
View File

@ -216,7 +216,7 @@ let constant : Parsetree.constant -> (Asttypes.constant, error) result =
end
| Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
| Pconst_char c -> Ok (Const_char c)
| Pconst_string (s,_,d) -> Ok (Const_string (s,d))
| Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d))
| Pconst_float (f,None)-> Ok (Const_float f)
| Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))

2
typing/untypeast.ml
View File

@ -132,7 +132,7 @@ let rec extract_letop_patterns n pat =
let constant = function
| Const_char c -> Pconst_char c
| Const_string (s,d) -> Pconst_string (s,Location.none,d)
| Const_string (s,loc,d) -> Pconst_string (s,loc,d)
| Const_int i -> Pconst_integer (Int.to_string i, None)
| Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
| Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')