Skip to content

Commit

Permalink
[typer] type int literals as float where expected
Browse files Browse the repository at this point in the history
see #10918
  • Loading branch information
Simn committed Mar 27, 2023
1 parent 10301c8 commit d3527fc
Show file tree
Hide file tree
Showing 5 changed files with 27 additions and 17 deletions.
31 changes: 21 additions & 10 deletions src/core/texpr.ml
Original file line number Diff line number Diff line change
Expand Up @@ -569,12 +569,23 @@ let rec constructor_side_effects e =
let replace_separators s c =
String.concat c (ExtString.String.nsplit s "_")

let type_constant basic c p =
let type_constant basic with_type c p =
match c with
| Int (s,_) ->
if String.length s > 10 && String.sub s 0 2 = "0x" then typing_error "Invalid hexadecimal integer" p;
(try mk (TConst (TInt (Int32.of_string s))) basic.tint p
with _ -> mk (TConst (TFloat s)) basic.tfloat p)
let float () =
mk (TConst (TFloat s)) basic.tfloat p
in
begin match with_type with
| WithType.WithType(t,_) when TOther.ExtType.is_float t ->
float()
| _ ->
begin try
mk (TConst (TInt (Int32.of_string s))) basic.tint p
with _ ->
float()
end
end
| Float (f,_) -> mk (TConst (TFloat f)) basic.tfloat p
| String(s,qs) -> mk (TConst (TString s)) basic.tstring p (* STRINGTODO: qs? *)
| Ident "true" -> mk (TConst (TBool true)) basic.tbool p
Expand All @@ -583,21 +594,21 @@ let type_constant basic c p =
| Ident t -> typing_error ("Invalid constant : " ^ t) p
| Regexp _ -> typing_error "Invalid constant" p

let rec type_constant_value basic (e,p) =
let rec type_constant_value basic with_type (e,p) =
match e with
| EConst c ->
type_constant basic c p
type_constant basic with_type c p
| EParenthesis e ->
type_constant_value basic e
type_constant_value basic with_type e
| EObjectDecl el ->
mk (TObjectDecl (List.map (fun (k,e) -> k,type_constant_value basic e) el)) (mk_anon (ref Closed)) p
mk (TObjectDecl (List.map (fun (k,e) -> k,type_constant_value basic with_type e) el)) (mk_anon (ref Closed)) p
| EArrayDecl el ->
mk (TArrayDecl (List.map (type_constant_value basic) el)) (basic.tarray t_dynamic) p
mk (TArrayDecl (List.map (type_constant_value basic with_type) el)) (basic.tarray t_dynamic) p
| _ ->
typing_error "Constant value expected" p

let is_constant_value basic e =
try (ignore (type_constant_value basic e); true) with Error (Custom _,_,_) -> false
try (ignore (type_constant_value basic WithType.value e); true) with Error (Custom _,_,_) -> false

let for_remap basic v e1 e2 p =
let v' = alloc_var v.v_kind v.v_name e1.etype e1.epos in
Expand Down Expand Up @@ -640,7 +651,7 @@ let build_metadata api t =
mk (TObjectDecl (List.map (fun (f,el,p) ->
if Hashtbl.mem h f then typing_error ("Duplicate metadata '" ^ f ^ "'") p;
Hashtbl.add h f ();
(f,null_pos,NoQuotes), mk (match el with [] -> TConst TNull | _ -> TArrayDecl (List.map (type_constant_value api) el)) (api.tarray t_dynamic) p
(f,null_pos,NoQuotes), mk (match el with [] -> TConst TNull | _ -> TArrayDecl (List.map (type_constant_value api WithType.value) el)) (api.tarray t_dynamic) p
) ml)) t_dynamic p
in
let make_meta l =
Expand Down
5 changes: 2 additions & 3 deletions src/core/withType.ml
Original file line number Diff line number Diff line change
@@ -1,5 +1,3 @@
open Type

type with_type_source_information = {
si_name : string;
si_doc : string option;
Expand All @@ -13,7 +11,7 @@ type with_type_source =
type t =
| NoValue
| Value of with_type_source option
| WithType of Type.t * with_type_source option
| WithType of TType.t * with_type_source option

let make_with_type_source_information name doc = {
si_name = name;
Expand All @@ -39,4 +37,5 @@ let to_string = function
| Some(FunctionArgument si | StructureField si) -> si.si_name
| _ -> "None"
in
let open TPrinting in
Printf.sprintf "WithType(%s, %s)" (s_type (print_context()) t) name
2 changes: 1 addition & 1 deletion src/optimization/analyzer.ml
Original file line number Diff line number Diff line change
Expand Up @@ -489,7 +489,7 @@ module ConstPropagation = DataFlow(struct
| Top | Bottom | EnumValue _ | Null _ ->
raise Not_found
| Const ct ->
let e' = Texpr.type_constant ctx.com.basic (tconst_to_const ct) e.epos in
let e' = Texpr.type_constant ctx.com.basic WithType.value (tconst_to_const ct) e.epos in
if not (type_change_ok ctx.com e'.etype e.etype) then raise Not_found;
e'
| ModuleType(mt,t) ->
Expand Down
2 changes: 1 addition & 1 deletion src/typing/matcher.ml
Original file line number Diff line number Diff line change
Expand Up @@ -347,7 +347,7 @@ module Pattern = struct
| _ -> ()
end;
let p = pos e in
let e = Texpr.type_constant ctx.com.basic ct p in
let e = Texpr.type_constant ctx.com.basic (WithType.with_type t) ct p in
unify_expected e.etype;
let ct = match e.eexpr with TConst ct -> ct | _ -> die "" __LOC__ in
PatConstructor(con_const ct p,[])
Expand Down
4 changes: 2 additions & 2 deletions src/typing/typer.ml
Original file line number Diff line number Diff line change
Expand Up @@ -1866,10 +1866,10 @@ and type_expr ?(mode=MGet) ctx (e,p) (with_type:WithType.t) =
| other -> typing_error (other ^ " is not a valid integer suffix") p)
| EConst (Float (s, Some suffix) as c) ->
(match suffix with
| "f64" -> Texpr.type_constant ctx.com.basic c p
| "f64" -> Texpr.type_constant ctx.com.basic with_type c p
| other -> typing_error (other ^ " is not a valid float suffix") p)
| EConst c ->
Texpr.type_constant ctx.com.basic c p
Texpr.type_constant ctx.com.basic with_type c p
| EBinop (OpNullCoal,e1,e2) ->
let vr = new value_reference ctx in
let e1 = type_expr ctx (Expr.ensure_block e1) with_type in
Expand Down

0 comments on commit d3527fc

Please sign in to comment.