Skip to content

Commit c8fc595

Browse files
Leonidas-from-XIVLeonidas-from-XIV
committed
Add value_binding to be able to parse out Zero_alloc
1 parent 371944f commit c8fc595

3 files changed

Lines changed: 33 additions & 22 deletions

File tree

‎src/loader/cmt.ml‎

Lines changed: 23 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,10 @@ let cmt_builddir : string ref = ref ""
3636
let read_core_type env ctyp =
3737
Cmi.read_type_expr env ctyp.ctyp_type
3838

39-
let rec read_pattern env parent doc pat =
39+
let zero_attr_of_ident (_ident, _, zero_alloc) =
40+
Doc_attr.lang_value_attr_of_zero_alloc zero_alloc
41+
42+
let rec read_pattern env parent doc vb pat =
4043
let source_loc = None in
4144
let open Signature in
4245
match pat.pat_desc with
@@ -53,8 +56,10 @@ let rec read_pattern env parent doc pat =
5356
Cmi.mark_type_expr pat.pat_type;
5457
let type_ = Cmi.read_type_expr env pat.pat_type in
5558
let value = Abstract in
56-
(* TODO read ext_attr out of id *)
57-
let ext_attr = [] in
59+
let ext_attr = [vb]
60+
|> let_bound_idents_with_modes_sorts_and_checks
61+
|> List.filter_map zero_attr_of_ident
62+
in
5863
[Value {id; source_loc; doc; type_; value; ext_attr}]
5964
#if OCAML_VERSION < (5,2, 0)
6065
| Tpat_alias(pat, id, _) ->
@@ -70,49 +75,52 @@ let rec read_pattern env parent doc pat =
7075
Cmi.mark_type_expr pat.pat_type;
7176
let type_ = Cmi.read_type_expr env pat.pat_type in
7277
let value = Abstract in
73-
let ext_attr = [] in
74-
Value {id; source_loc; doc; type_; value; ext_attr} :: read_pattern env parent doc pat
78+
let ext_attr = [vb]
79+
|> let_bound_idents_with_modes_sorts_and_checks
80+
|> List.filter_map zero_attr_of_ident
81+
in
82+
Value {id; source_loc; doc; type_; value; ext_attr} :: read_pattern env parent doc vb pat
7583
| Tpat_constant _ -> []
7684
| Tpat_tuple pats ->
7785
#if OCAML_VERSION >= (5, 4, 0) || defined OXCAML
7886
let pats = List.map snd pats (* remove labels *) in
7987
#endif
80-
List.concat (List.map (read_pattern env parent doc) pats)
88+
List.concat (List.map (read_pattern env parent doc vb) pats)
8189
#if defined OXCAML
8290
| Tpat_unboxed_tuple pats ->
83-
List.concat (List.map (fun (_, p, _) -> read_pattern env parent doc p) pats)
91+
List.concat (List.map (fun (_, p, _) -> read_pattern env parent doc vb p) pats)
8492
#endif
8593
#if OCAML_VERSION < (4, 13, 0)
8694
| Tpat_construct(_, _, pats) ->
8795
#else
8896
| Tpat_construct(_,_,pats,_) ->
8997
#endif
90-
List.concat (List.map (read_pattern env parent doc) pats)
98+
List.concat (List.map (read_pattern env parent doc vb) pats)
9199
| Tpat_variant(_, None, _) -> []
92100
| Tpat_variant(_, Some pat, _) ->
93-
read_pattern env parent doc pat
101+
read_pattern env parent doc vb pat
94102
| Tpat_record(pats, _) ->
95103
List.concat
96104
(List.map
97-
(fun (_, _, pat) -> read_pattern env parent doc pat)
105+
(fun (_, _, pat) -> read_pattern env parent doc vb pat)
98106
pats)
99107
#if defined OXCAML
100108
| Tpat_record_unboxed_product(pats, _) ->
101109
List.concat
102110
(List.map
103-
(fun (_, _, pat) -> read_pattern env parent doc pat)
111+
(fun (_, _, pat) -> read_pattern env parent doc vb pat)
104112
pats)
105113
| Tpat_array (_, _, pats) ->
106114
#elif OCAML_VERSION < (5, 4, 0)
107115
| Tpat_array pats ->
108116
#else
109117
| Tpat_array (_, pats) ->
110118
#endif
111-
List.concat (List.map (read_pattern env parent doc) pats)
119+
List.concat (List.map (read_pattern env parent doc vb) pats)
112120
| Tpat_or(pat, _, _) ->
113-
read_pattern env parent doc pat
121+
read_pattern env parent doc vb pat
114122
| Tpat_lazy pat ->
115-
read_pattern env parent doc pat
123+
read_pattern env parent doc vb pat
116124
#if OCAML_VERSION >= (4,8,0) && OCAML_VERSION < (4,11,0)
117125
| Tpat_exception pat ->
118126
read_pattern env parent doc pat
@@ -125,7 +133,7 @@ let rec read_pattern env parent doc pat =
125133
let read_value_binding env parent vb =
126134
let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
127135
let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container vb.vb_attributes in
128-
read_pattern env parent doc vb.vb_pat
136+
read_pattern env parent doc vb vb.vb_pat
129137

130138
let read_value_bindings env parent vbs =
131139
let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in

‎src/loader/doc_attr.ml‎

Lines changed: 9 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -74,21 +74,23 @@ let attribute_unpack = function
7474
| { Location.txt = name; loc }, attr_payload -> (name, attr_payload, loc)
7575
#endif
7676

77-
let attrs_of_value_description (vd : Types.value_description) =
78-
#if defined OXCAML
79-
let zero_alloc = match vd.val_zero_alloc |> Zero_alloc.get with
77+
let lang_value_attr_of_zero_alloc zero_alloc =
78+
match Zero_alloc.get zero_alloc with
8079
| Default_zero_alloc -> None
8180
| Ignore_assert_all -> None
8281
| Assume { arity; _} ->
83-
Some ( Lang.Value.Zero_alloc.{ opt = false; strict = false; arity; custom_error_msg = None })
82+
Some (Lang.Value.Zero_alloc ( Lang.Value.Zero_alloc.{ opt = false; strict = false; arity; custom_error_msg = None }))
8483
| Check { strict; opt; arity; custom_error_msg } ->
85-
Some ( Lang.Value.Zero_alloc.{ opt; strict; arity; custom_error_msg })
86-
in
84+
Some (Lang.Value.Zero_alloc ( Lang.Value.Zero_alloc.{ opt; strict; arity; custom_error_msg }))
85+
86+
let attrs_of_value_description (vd : Types.value_description) =
87+
#if defined OXCAML
88+
let zero_alloc = lang_value_attr_of_zero_alloc vd.val_zero_alloc in
8789
#else
8890
let zero_alloc = None in
8991
#endif
9092
match zero_alloc with
91-
| Some za -> [Lang.Value.Zero_alloc za]
93+
| Some za -> [za]
9294
| None -> []
9395

9496
type payload = string * Location.t

‎src/loader/doc_attr.mli‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -93,4 +93,5 @@ type parsed_attribute =
9393
]
9494

9595
val parse_attribute : Parsetree.attribute -> parsed_attribute option
96+
val lang_value_attr_of_zero_alloc : Zero_alloc.t -> Lang.Value.attr option
9697
val attrs_of_value_description : Types.value_description -> Lang.Value.attr list

0 commit comments

Comments
 (0)