Skip to content

Commit d8dd2f0

Browse files
bobzhangbobzhang
committed
fix #2162 
1 parent 28f38ff commit d8dd2f0

7 files changed

+180
-104
lines changed

‎jscomp/bin/all_ounit_tests.ml

+11
Original file line numberDiff line numberDiff line change
@@ -5436,6 +5436,17 @@ external ff :
54365436
(not (Ext_string.is_empty should_err.stderr))
54375437

54385438
end;
5439+
__LOC__ >:: begin fun _ ->
5440+
let should_err = bsc_check_eval {|
5441+
external foo_bar :
5442+
(_ [@bs.as "foo"]) ->
5443+
string ->
5444+
string = "bar"
5445+
[@@bs.send]
5446+
|} in
5447+
OUnit.assert_bool __LOC__
5448+
(Ext_string.contain_substring should_err.stderr "Ill defined attribute")
5449+
end;
54395450

54405451
(* __LOC__ >:: begin fun _ -> *)
54415452
(* let should_infer = perform_bsc [| "-i"; "-bs-eval"|] {| *)

‎jscomp/bin/bsdep.ml

+37-25
Original file line numberDiff line numberDiff line change
@@ -30866,22 +30866,22 @@ end = struct
3086630866

3086730867

3086830868
let variant_can_bs_unwrap_fields row_fields =
30869-
let validity = (List.fold_left
30870-
begin fun st row ->
30871-
match st, row with
30872-
| (* we've seen no fields or only valid fields so far *)
30873-
(`No_fields | `Valid_fields),
30874-
(* and this field has one constructor arg that we can unwrap to *)
30875-
Parsetree.Rtag (label, attrs, false, ([ _ ]))
30876-
->
30877-
`Valid_fields
30878-
| (* otherwise, this field or a previous field was invalid *)
30879-
_ ->
30880-
`Invalid_field
30881-
end
30882-
`No_fields
30883-
row_fields
30884-
)
30869+
let validity =
30870+
List.fold_left
30871+
begin fun st row ->
30872+
match st, row with
30873+
| (* we've seen no fields or only valid fields so far *)
30874+
(`No_fields | `Valid_fields),
30875+
(* and this field has one constructor arg that we can unwrap to *)
30876+
Parsetree.Rtag (label, attrs, false, ([ _ ]))
30877+
->
30878+
`Valid_fields
30879+
| (* otherwise, this field or a previous field was invalid *)
30880+
_ ->
30881+
`Invalid_field
30882+
end
30883+
`No_fields
30884+
row_fields
3088530885
in
3088630886
match validity with
3088730887
| `Valid_fields -> true
@@ -31469,7 +31469,7 @@ let handle_attributes
3146931469
new_arg_types,
3147031470
if arg_type = Ignore then i
3147131471
else i + 1
31472-
)
31472+
)
3147331473
) arg_types_ty
3147431474
(match st with
3147531475
| {val_send_pipe = Some obj; _ } ->
@@ -31543,7 +31543,7 @@ let handle_attributes
3154331543
if arg_type_specs_length = 2 then
3154431544
Js_get_index {js_get_index_scopes = scopes}
3154531545
else Location.raise_errorf ~loc
31546-
"Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
31546+
"Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
3154731547

3154831548
| {get_index = true; _}
3154931549

@@ -31570,7 +31570,7 @@ let handle_attributes
3157031570
set_index = false;
3157131571
return_wrapper = _;
3157231572
mk_obj = _ ;
31573-
} ->
31573+
} ->
3157431574
begin match arg_types_ty, new_name, val_name with
3157531575
| [], `Nm_na, _ -> Js_module_as_var external_module_name
3157631576
| _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
@@ -31673,10 +31673,22 @@ let handle_attributes
3167331673
mk_obj = _ ;
3167431674
return_wrapper = _ ;
3167531675
} ->
31676-
if arg_type_specs_length > 0 then
31677-
Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
31678-
else
31679-
Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
31676+
31677+
(* PR #2162 - since when we assemble arguments the first argument in
31678+
[@@bs.send] is ignored
31679+
*)
31680+
begin match arg_type_specs with
31681+
| [] ->
31682+
Location.raise_errorf
31683+
~loc "Ill defined attribute [@@bs.send] (at least one argument)"
31684+
| {arg_type = Arg_cst _ ; arg_label = _} :: _
31685+
->
31686+
Location.raise_errorf
31687+
~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
31688+
| _ :: _ ->
31689+
Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
31690+
end
31691+
3168031692
| {val_send = #bundle_source; _ }
3168131693
-> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
3168231694

@@ -31751,7 +31763,7 @@ let handle_attributes
3175131763
if arg_type_specs_length = 2 then
3175231764
Js_set { js_set_scopes = scopes ; js_set_name = name}
3175331765
else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
31754-
31766+
3175531767
| {set_name = #bundle_source; _}
3175631768
-> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
3175731769

@@ -31797,7 +31809,7 @@ let handle_attributes
3179731809
return_wrapper = _;
3179831810

3179931811
}
31800-
-> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
31812+
-> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
3180131813
begin
3180231814
Ast_ffi_types.check_ffi ~loc ffi;
3180331815
(* result type can not be labeled *)

‎jscomp/bin/bsppx.ml

+37-25
Original file line numberDiff line numberDiff line change
@@ -12878,22 +12878,22 @@ end = struct
1287812878

1287912879

1288012880
let variant_can_bs_unwrap_fields row_fields =
12881-
let validity = (List.fold_left
12882-
begin fun st row ->
12883-
match st, row with
12884-
| (* we've seen no fields or only valid fields so far *)
12885-
(`No_fields | `Valid_fields),
12886-
(* and this field has one constructor arg that we can unwrap to *)
12887-
Parsetree.Rtag (label, attrs, false, ([ _ ]))
12888-
->
12889-
`Valid_fields
12890-
| (* otherwise, this field or a previous field was invalid *)
12891-
_ ->
12892-
`Invalid_field
12893-
end
12894-
`No_fields
12895-
row_fields
12896-
)
12881+
let validity =
12882+
List.fold_left
12883+
begin fun st row ->
12884+
match st, row with
12885+
| (* we've seen no fields or only valid fields so far *)
12886+
(`No_fields | `Valid_fields),
12887+
(* and this field has one constructor arg that we can unwrap to *)
12888+
Parsetree.Rtag (label, attrs, false, ([ _ ]))
12889+
->
12890+
`Valid_fields
12891+
| (* otherwise, this field or a previous field was invalid *)
12892+
_ ->
12893+
`Invalid_field
12894+
end
12895+
`No_fields
12896+
row_fields
1289712897
in
1289812898
match validity with
1289912899
| `Valid_fields -> true
@@ -13481,7 +13481,7 @@ let handle_attributes
1348113481
new_arg_types,
1348213482
if arg_type = Ignore then i
1348313483
else i + 1
13484-
)
13484+
)
1348513485
) arg_types_ty
1348613486
(match st with
1348713487
| {val_send_pipe = Some obj; _ } ->
@@ -13555,7 +13555,7 @@ let handle_attributes
1355513555
if arg_type_specs_length = 2 then
1355613556
Js_get_index {js_get_index_scopes = scopes}
1355713557
else Location.raise_errorf ~loc
13558-
"Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
13558+
"Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
1355913559

1356013560
| {get_index = true; _}
1356113561

@@ -13582,7 +13582,7 @@ let handle_attributes
1358213582
set_index = false;
1358313583
return_wrapper = _;
1358413584
mk_obj = _ ;
13585-
} ->
13585+
} ->
1358613586
begin match arg_types_ty, new_name, val_name with
1358713587
| [], `Nm_na, _ -> Js_module_as_var external_module_name
1358813588
| _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
@@ -13685,10 +13685,22 @@ let handle_attributes
1368513685
mk_obj = _ ;
1368613686
return_wrapper = _ ;
1368713687
} ->
13688-
if arg_type_specs_length > 0 then
13689-
Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
13690-
else
13691-
Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
13688+
13689+
(* PR #2162 - since when we assemble arguments the first argument in
13690+
[@@bs.send] is ignored
13691+
*)
13692+
begin match arg_type_specs with
13693+
| [] ->
13694+
Location.raise_errorf
13695+
~loc "Ill defined attribute [@@bs.send] (at least one argument)"
13696+
| {arg_type = Arg_cst _ ; arg_label = _} :: _
13697+
->
13698+
Location.raise_errorf
13699+
~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
13700+
| _ :: _ ->
13701+
Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
13702+
end
13703+
1369213704
| {val_send = #bundle_source; _ }
1369313705
-> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
1369413706

@@ -13763,7 +13775,7 @@ let handle_attributes
1376313775
if arg_type_specs_length = 2 then
1376413776
Js_set { js_set_scopes = scopes ; js_set_name = name}
1376513777
else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
13766-
13778+
1376713779
| {set_name = #bundle_source; _}
1376813780
-> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
1376913781

@@ -13809,7 +13821,7 @@ let handle_attributes
1380913821
return_wrapper = _;
1381013822

1381113823
}
13812-
-> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
13824+
-> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
1381313825
begin
1381413826
Ast_ffi_types.check_ffi ~loc ffi;
1381513827
(* result type can not be labeled *)

‎jscomp/bin/whole_compiler.ml

+42-27
Original file line numberDiff line numberDiff line change
@@ -94941,7 +94941,8 @@ let assemble_args call_loc ffi js_splice arg_types args : E.t list * E.t option
9494194941
let accs, eff = aux labels args in
9494294942
let acc, new_eff = ocaml_to_js_eff arg_kind arg in
9494394943
Ext_list.append acc accs, Ext_list.append new_eff eff
94944-
| { arg_label = Empty None | Label (_,None) | Optional _ ; _ } :: _ , [] -> assert false
94944+
| { arg_label = Empty None | Label (_,None) | Optional _ ; _ } :: _ , []
94945+
-> assert false
9494594946
| [], _ :: _ -> assert false
9494694947

9494794948
in
@@ -95079,7 +95080,9 @@ let translate_ffi
9507995080
| Js_send {splice = js_splice ; name ; pipe = false; js_send_scopes = scopes } ->
9508095081
begin match args with
9508195082
| self :: args ->
95082-
let [@warning"-8"] ( self_type::arg_types )
95083+
(* PR2162 [self_type] more checks in syntax:
95084+
- should not be [bs.as] *)
95085+
let [@warning"-8"] ( _self_type::arg_types )
9508395086
= arg_types in
9508495087
let args, eff = assemble_args call_loc ffi js_splice arg_types args in
9508595088
add_eff eff @@
@@ -105345,22 +105348,22 @@ end = struct
105345105348

105346105349

105347105350
let variant_can_bs_unwrap_fields row_fields =
105348-
let validity = (List.fold_left
105349-
begin fun st row ->
105350-
match st, row with
105351-
| (* we've seen no fields or only valid fields so far *)
105352-
(`No_fields | `Valid_fields),
105353-
(* and this field has one constructor arg that we can unwrap to *)
105354-
Parsetree.Rtag (label, attrs, false, ([ _ ]))
105355-
->
105356-
`Valid_fields
105357-
| (* otherwise, this field or a previous field was invalid *)
105358-
_ ->
105359-
`Invalid_field
105360-
end
105361-
`No_fields
105362-
row_fields
105363-
)
105351+
let validity =
105352+
List.fold_left
105353+
begin fun st row ->
105354+
match st, row with
105355+
| (* we've seen no fields or only valid fields so far *)
105356+
(`No_fields | `Valid_fields),
105357+
(* and this field has one constructor arg that we can unwrap to *)
105358+
Parsetree.Rtag (label, attrs, false, ([ _ ]))
105359+
->
105360+
`Valid_fields
105361+
| (* otherwise, this field or a previous field was invalid *)
105362+
_ ->
105363+
`Invalid_field
105364+
end
105365+
`No_fields
105366+
row_fields
105364105367
in
105365105368
match validity with
105366105369
| `Valid_fields -> true
@@ -105948,7 +105951,7 @@ let handle_attributes
105948105951
new_arg_types,
105949105952
if arg_type = Ignore then i
105950105953
else i + 1
105951-
)
105954+
)
105952105955
) arg_types_ty
105953105956
(match st with
105954105957
| {val_send_pipe = Some obj; _ } ->
@@ -106022,7 +106025,7 @@ let handle_attributes
106022106025
if arg_type_specs_length = 2 then
106023106026
Js_get_index {js_get_index_scopes = scopes}
106024106027
else Location.raise_errorf ~loc
106025-
"Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
106028+
"Ill defined attribute [@@bs.get_index] (arity expected 2 : while %d)" arg_type_specs_length
106026106029

106027106030
| {get_index = true; _}
106028106031

@@ -106049,7 +106052,7 @@ let handle_attributes
106049106052
set_index = false;
106050106053
return_wrapper = _;
106051106054
mk_obj = _ ;
106052-
} ->
106055+
} ->
106053106056
begin match arg_types_ty, new_name, val_name with
106054106057
| [], `Nm_na, _ -> Js_module_as_var external_module_name
106055106058
| _, `Nm_na, _ -> Js_module_as_fn {splice; external_module_name }
@@ -106152,10 +106155,22 @@ let handle_attributes
106152106155
mk_obj = _ ;
106153106156
return_wrapper = _ ;
106154106157
} ->
106155-
if arg_type_specs_length > 0 then
106156-
Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
106157-
else
106158-
Location.raise_errorf ~loc "Ill defined attribute [@@bs.send] (at least one argument)"
106158+
106159+
(* PR #2162 - since when we assemble arguments the first argument in
106160+
[@@bs.send] is ignored
106161+
*)
106162+
begin match arg_type_specs with
106163+
| [] ->
106164+
Location.raise_errorf
106165+
~loc "Ill defined attribute [@@bs.send] (at least one argument)"
106166+
| {arg_type = Arg_cst _ ; arg_label = _} :: _
106167+
->
106168+
Location.raise_errorf
106169+
~loc "Ill defined attribute [@@bs.send] (first argument can not be const)"
106170+
| _ :: _ ->
106171+
Js_send {splice ; name; js_send_scopes = scopes ; pipe = false}
106172+
end
106173+
106159106174
| {val_send = #bundle_source; _ }
106160106175
-> Location.raise_errorf ~loc "You used an FFI attribute that can't be used with [@@bs.send]"
106161106176

@@ -106230,7 +106245,7 @@ let handle_attributes
106230106245
if arg_type_specs_length = 2 then
106231106246
Js_set { js_set_scopes = scopes ; js_set_name = name}
106232106247
else Location.raise_errorf ~loc "Ill defined attribute [@@bs.set] (two args required)"
106233-
106248+
106234106249
| {set_name = #bundle_source; _}
106235106250
-> Location.raise_errorf ~loc "conflict attributes found with [@@bs.set]"
106236106251

@@ -106276,7 +106291,7 @@ let handle_attributes
106276106291
return_wrapper = _;
106277106292

106278106293
}
106279-
-> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
106294+
-> Location.raise_errorf ~loc "Could not infer which FFI category it belongs to, maybe you forgot [%@%@bs.val]? " in
106280106295
begin
106281106296
Ast_ffi_types.check_ffi ~loc ffi;
106282106297
(* result type can not be labeled *)

‎jscomp/core/lam_compile_external_call.ml

+5-2
Original file line numberDiff line numberDiff line change
@@ -184,7 +184,8 @@ let assemble_args call_loc ffi js_splice arg_types args : E.t list * E.t option
184184
let accs, eff = aux labels args in
185185
let acc, new_eff = ocaml_to_js_eff arg_kind arg in
186186
Ext_list.append acc accs, Ext_list.append new_eff eff
187-
| { arg_label = Empty None | Label (_,None) | Optional _ ; _ } :: _ , [] -> assert false
187+
| { arg_label = Empty None | Label (_,None) | Optional _ ; _ } :: _ , []
188+
-> assert false
188189
| [], _ :: _ -> assert false
189190

190191
in
@@ -322,7 +323,9 @@ let translate_ffi
322323
| Js_send {splice = js_splice ; name ; pipe = false; js_send_scopes = scopes } ->
323324
begin match args with
324325
| self :: args ->
325-
let [@warning"-8"] ( self_type::arg_types )
326+
(* PR2162 [self_type] more checks in syntax:
327+
- should not be [bs.as] *)
328+
let [@warning"-8"] ( _self_type::arg_types )
326329
= arg_types in
327330
let args, eff = assemble_args call_loc ffi js_splice arg_types args in
328331
add_eff eff @@

0 commit comments

Comments
 (0)