From 6300a38ce3119a441b11a7022903e28ea6041b09 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Fri, 17 Apr 2026 14:10:29 +0200 Subject: [PATCH 01/13] Add `[@@zero_alloc]` attribute --- CHANGES.md | 1 + src/document/generator.ml | 6 ++++++ src/loader/cmi.ml | 3 ++- src/loader/cmt.ml | 7 +++++-- src/loader/cmti.ml | 3 ++- src/loader/doc_attr.ml | 18 +++++++++++++++++- src/loader/doc_attr.mli | 2 ++ src/model/lang.ml | 2 ++ src/odoc/extract_code.cppo.ml | 1 + src/odoc/extract_code.mli | 2 ++ src/xref2/lang_of.ml | 2 ++ test/generators/cases/oxcaml.mli | 5 +++++ test/generators/html/Oxcaml.html | 19 +++++++++++++++++++ test/generators/latex/Oxcaml.tex | 2 ++ test/generators/man/Oxcaml.3o | 7 +++++++ test/generators/markdown/Oxcaml.md | 5 +++++ 16 files changed, 80 insertions(+), 5 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index fb32f45690..bbc5b1074c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,7 @@ invocation, eliminating the need for shell scripting (@davesnx, #1387) - Support for OxCaml (@lukemaurer, @art-w, #1399) - OCaml 5.5.0 support (@panglesd, @xvw, #1406) +- Support for OxCaml zero alloc definitions (@Leonidas-from-XIV, #) ### Fixed - Fix compile-time crashing bugs #930 and #1385 (@jonludlam, #1400) diff --git a/src/document/generator.ml b/src/document/generator.ml index 0e481f582c..53050e7d31 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -988,6 +988,11 @@ module Make (Syntax : SYNTAX) = struct | External _ -> ([ "external" ], Syntax.Type.External.semicolon) in let name = Paths.Identifier.name t.id in + let zero_alloc = + match List.mem Odoc_model.Lang.Value.Zero_alloc t.ext_attr with + | true -> O.txt " " ++ O.txt "[@@zero_alloc]" + | false -> O.noop + in let content = O.documentedSrc (O.box_hv @@ -995,6 +1000,7 @@ module Make (Syntax : SYNTAX) = struct ++ O.txt " " ++ O.txt name ++ O.txt Syntax.Type.annotation_separator ++ O.cut ++ type_expr t.type_ + ++ O.cut ++ zero_alloc ++ if semicolon then O.txt ";" else O.noop) in let attr = [ "value" ] @ extra_attr in diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 06270d51a0..498706cc11 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -757,7 +757,8 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd = External primitives | _ -> assert false in - Value { Value.id; source_loc; doc; type_; value } + let ext_attr = List.filter_map Doc_attr.known_attribute vd.val_attributes in + Value { Value.id; source_loc; doc; type_; value; ext_attr } #if defined OXCAML let is_mutable = Types.is_mutable diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index bf5131878d..27eebcdd70 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -53,7 +53,9 @@ let rec read_pattern env parent doc pat = Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in - [Value {id; source_loc; doc; type_; value}] + (* TODO read ext_attr out of id *) + let ext_attr = [] in + [Value {id; source_loc; doc; type_; value; ext_attr}] #if OCAML_VERSION < (5,2, 0) | Tpat_alias(pat, id, _) -> #elif defined OXCAML @@ -68,7 +70,8 @@ let rec read_pattern env parent doc pat = Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in - Value {id; source_loc; doc; type_; value} :: read_pattern env parent doc pat + let ext_attr = [] in + Value {id; source_loc; doc; type_; value; ext_attr} :: read_pattern env parent doc pat | Tpat_constant _ -> [] | Tpat_tuple pats -> #if OCAML_VERSION >= (5, 4, 0) || defined OXCAML diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index e74246692e..6c8d6831d0 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -233,7 +233,8 @@ let read_value_description env parent vd = | [] -> Value.Abstract | primitives -> External primitives in - Value { Value.id; source_loc; doc; type_; value } + let ext_attr = List.filter_map Doc_attr.known_attribute vd.val_attributes in + Value { Value.id; source_loc; doc; type_; value; ext_attr } let read_type_parameter (ctyp, var_and_injectivity) = let open TypeDecl in diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index 0489311906..0a44146c23 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -74,6 +74,12 @@ let attribute_unpack = function | { Location.txt = name; loc }, attr_payload -> (name, attr_payload, loc) #endif +let known_attribute attr = + let name, _, _ = attribute_unpack attr in + match String.equal name "zero_alloc" with + | true -> Some Lang.Value.Zero_alloc + | false -> None + type payload = string * Location.t type parsed_attribute = @@ -81,7 +87,8 @@ type parsed_attribute = | `Doc of payload (* Attached comment. *) | `Stop of Location.t (* [(**/**)]. *) | `Alert of string * payload option * Location.t - (* [`Alert (name, payload, loc)] is for [\[@@alert name "payload"\]] attributes. *) ] + (* [`Alert (name, payload, loc)] is for [\[@@alert name "payload"\]] attributes. *) + | `Zero_alloc (* Does not allocate on heap *) ] (** Recognize an attribute. *) let parse_attribute : Parsetree.attribute -> parsed_attribute option = @@ -105,6 +112,9 @@ let parse_attribute : Parsetree.attribute -> parsed_attribute option = Some (name, payload) -> Some (`Alert (name, payload, attr_loc)) | None -> None) + | "zero_alloc" -> + (* TODO: unclear if this should be detected here *) + Some `Zero_alloc | _ -> None let is_stop_comment attr = @@ -137,6 +147,9 @@ let attached ~warnings_tag internal_tags parent attrs = | Some (`Alert (name, p, loc)) -> let elt = mk_alert_payload ~loc name p in loop acc_docs (elt :: acc_alerts) rest + | Some `Zero_alloc -> + (* TODO potentially do something useful here *) + loop acc_docs acc_alerts rest | Some (`Text _ | `Stop _) | None -> loop acc_docs acc_alerts rest) | [] -> (List.rev acc_docs, List.rev acc_alerts) in @@ -214,6 +227,9 @@ let extract_top_comment internal_tags ~warnings_tag ~classify parent items = let attr_loc = read_location attr_loc in `Alert (Location_.at attr_loc (`Tag (`Alert (name, p)))) | Some (`Stop _) -> `Return (* Stop at stop-comments. *) + | Some (`Zero_alloc) -> + (* TODO possibly do something here *) + `Skip | None -> `Skip (* Skip unrecognized attributes. *)) | Some `Open -> `Skip (* Skip open statements *) | None -> `Return diff --git a/src/loader/doc_attr.mli b/src/loader/doc_attr.mli index 9db500a3ec..371dfa8e10 100644 --- a/src/loader/doc_attr.mli +++ b/src/loader/doc_attr.mli @@ -90,6 +90,8 @@ type parsed_attribute = | `Stop of Location.t (* [(**/**)]. *) | `Alert of string * payload option * Location.t (* [`Alert (name, payload, loc)] is for [\[@@alert name "payload"\]] attributes. *) + | `Zero_alloc (* Does not allocate on heap *) ] val parse_attribute : Parsetree.attribute -> parsed_attribute option +val known_attribute : Parsetree.attribute -> Lang.Value.attr option diff --git a/src/model/lang.ml b/src/model/lang.ml index 432eb88152..fedde646b7 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -320,6 +320,7 @@ end = and Value : sig type value = Abstract | External of string list + type attr = Zero_alloc type t = { id : Identifier.Value.t; @@ -327,6 +328,7 @@ and Value : sig value : value; doc : Comment.docs; type_ : TypeExpr.t; + ext_attr : attr list; } end = Value diff --git a/src/odoc/extract_code.cppo.ml b/src/odoc/extract_code.cppo.ml index a31282f1d8..25b54f41c9 100644 --- a/src/odoc/extract_code.cppo.ml +++ b/src/odoc/extract_code.cppo.ml @@ -75,6 +75,7 @@ let iterator line_directives oc names = let attribute _ attr = match Odoc_loader.parse_attribute attr with | None | Some (`Stop _ | `Alert _) -> () + | Some `Zero_alloc -> () | Some (`Text (doc, loc) | `Doc (doc, loc)) -> let ast_docs = Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:doc diff --git a/src/odoc/extract_code.mli b/src/odoc/extract_code.mli index 263ce49cc3..f350e174a9 100644 --- a/src/odoc/extract_code.mli +++ b/src/odoc/extract_code.mli @@ -1,3 +1,5 @@ +(** [extract ~dst ~input ~names ~line_directives ~warnings_options] extracts source code from document blocks. + @arg dst File path to write to *) val extract : dst:string option -> input:string -> diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index a1b17fb6a5..ec565d4c1a 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -692,6 +692,8 @@ and value_ map parent id v = doc = docs (parent :> Identifier.LabelParent.t) v.doc; type_ = type_expr map (parent :> Identifier.LabelParent.t) v.type_; value = v.value; + (* TODO this needs to be fixed *) + ext_attr = []; } and typ_ext map parent t = diff --git a/test/generators/cases/oxcaml.mli b/test/generators/cases/oxcaml.mli index 9a60035c51..ea697c78cc 100644 --- a/test/generators/cases/oxcaml.mli +++ b/test/generators/cases/oxcaml.mli @@ -1,2 +1,7 @@ val f : int -> ('a . 'a -> 'a) -> unit (** Polymorphic arguments require parentheses *) + +val add : bool -> int -> int -> int [@@zero_alloc] +(** Zero allocation bindings have an extension attribute attached. + See https://oxcaml.org/documentation/miscellaneous-extensions/zero_alloc_check/ + *) diff --git a/test/generators/html/Oxcaml.html b/test/generators/html/Oxcaml.html index f6760c5410..e22dc624ad 100644 --- a/test/generators/html/Oxcaml.html +++ b/test/generators/html/Oxcaml.html @@ -34,6 +34,25 @@

Module Oxcaml

Polymorphic arguments require parentheses

+
+
+ + + val add : + bool -> + int -> + int -> int + [@@zero_alloc] + + +
+
+

Zero allocation bindings have an extension attribute attached. + See + https://oxcaml.org/documentation/miscellaneous-extensions/zero_alloc_check/ +

+
+
diff --git a/test/generators/latex/Oxcaml.tex b/test/generators/latex/Oxcaml.tex index db657fcbe7..de027ca4c5 100644 --- a/test/generators/latex/Oxcaml.tex +++ b/test/generators/latex/Oxcaml.tex @@ -1,5 +1,7 @@ \section{Module \ocamlinlinecode{Oxcaml}}\label{Oxcaml}% \label{Oxcaml--val-f}\ocamlcodefragment{\ocamltag{keyword}{val} f : int \ocamltag{arrow}{$\rightarrow$} ('a.\allowbreak{} \ocamltag{type-var}{'a} \ocamltag{arrow}{$\rightarrow$} \ocamltag{type-var}{'a}) \ocamltag{arrow}{$\rightarrow$} unit}\begin{ocamlindent}Polymorphic arguments require parentheses\end{ocamlindent}% \medbreak +\label{Oxcaml--val-add}\ocamlcodefragment{\ocamltag{keyword}{val} add : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc]}\begin{ocamlindent}Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero\_alloc\_check/\end{ocamlindent}% +\medbreak diff --git a/test/generators/man/Oxcaml.3o b/test/generators/man/Oxcaml.3o index a3daa8e343..3a67286f28 100644 --- a/test/generators/man/Oxcaml.3o +++ b/test/generators/man/Oxcaml.3o @@ -17,4 +17,11 @@ Oxcaml .ti +2 Polymorphic arguments require parentheses .nf +.sp +\f[CB]val\fR add : bool \f[CB]\->\fR int \f[CB]\->\fR int \f[CB]\->\fR int [@@zero_alloc] +.fi +.br +.ti +2 +Zero allocation bindings have an extension attribute attached\. See https://oxcaml\.org/documentation/miscellaneous-extensions/zero_alloc_check/ +.nf diff --git a/test/generators/markdown/Oxcaml.md b/test/generators/markdown/Oxcaml.md index 76d86c56a3..7a57168476 100644 --- a/test/generators/markdown/Oxcaml.md +++ b/test/generators/markdown/Oxcaml.md @@ -5,3 +5,8 @@ val f : int -> ('a. 'a -> 'a) -> unit ``` Polymorphic arguments require parentheses + +```ocaml +val add : bool -> int -> int -> int [@@zero_alloc] +``` +Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero\_alloc\_check/ From fa9f14c7b58ceeeefd68f27658701042be38c32c Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Tue, 28 Apr 2026 11:09:44 +0200 Subject: [PATCH 02/13] Remove `Zero_alloc` from `Doc_attr` --- src/loader/doc_attr.ml | 12 +----------- src/loader/doc_attr.mli | 1 - src/odoc/extract_code.cppo.ml | 1 - 3 files changed, 1 insertion(+), 13 deletions(-) diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index 0a44146c23..610938c59f 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -87,8 +87,7 @@ type parsed_attribute = | `Doc of payload (* Attached comment. *) | `Stop of Location.t (* [(**/**)]. *) | `Alert of string * payload option * Location.t - (* [`Alert (name, payload, loc)] is for [\[@@alert name "payload"\]] attributes. *) - | `Zero_alloc (* Does not allocate on heap *) ] + (* [`Alert (name, payload, loc)] is for [\[@@alert name "payload"\]] attributes. *) ] (** Recognize an attribute. *) let parse_attribute : Parsetree.attribute -> parsed_attribute option = @@ -112,9 +111,6 @@ let parse_attribute : Parsetree.attribute -> parsed_attribute option = Some (name, payload) -> Some (`Alert (name, payload, attr_loc)) | None -> None) - | "zero_alloc" -> - (* TODO: unclear if this should be detected here *) - Some `Zero_alloc | _ -> None let is_stop_comment attr = @@ -147,9 +143,6 @@ let attached ~warnings_tag internal_tags parent attrs = | Some (`Alert (name, p, loc)) -> let elt = mk_alert_payload ~loc name p in loop acc_docs (elt :: acc_alerts) rest - | Some `Zero_alloc -> - (* TODO potentially do something useful here *) - loop acc_docs acc_alerts rest | Some (`Text _ | `Stop _) | None -> loop acc_docs acc_alerts rest) | [] -> (List.rev acc_docs, List.rev acc_alerts) in @@ -227,9 +220,6 @@ let extract_top_comment internal_tags ~warnings_tag ~classify parent items = let attr_loc = read_location attr_loc in `Alert (Location_.at attr_loc (`Tag (`Alert (name, p)))) | Some (`Stop _) -> `Return (* Stop at stop-comments. *) - | Some (`Zero_alloc) -> - (* TODO possibly do something here *) - `Skip | None -> `Skip (* Skip unrecognized attributes. *)) | Some `Open -> `Skip (* Skip open statements *) | None -> `Return diff --git a/src/loader/doc_attr.mli b/src/loader/doc_attr.mli index 371dfa8e10..43851df7ab 100644 --- a/src/loader/doc_attr.mli +++ b/src/loader/doc_attr.mli @@ -90,7 +90,6 @@ type parsed_attribute = | `Stop of Location.t (* [(**/**)]. *) | `Alert of string * payload option * Location.t (* [`Alert (name, payload, loc)] is for [\[@@alert name "payload"\]] attributes. *) - | `Zero_alloc (* Does not allocate on heap *) ] val parse_attribute : Parsetree.attribute -> parsed_attribute option diff --git a/src/odoc/extract_code.cppo.ml b/src/odoc/extract_code.cppo.ml index 25b54f41c9..a31282f1d8 100644 --- a/src/odoc/extract_code.cppo.ml +++ b/src/odoc/extract_code.cppo.ml @@ -75,7 +75,6 @@ let iterator line_directives oc names = let attribute _ attr = match Odoc_loader.parse_attribute attr with | None | Some (`Stop _ | `Alert _) -> () - | Some `Zero_alloc -> () | Some (`Text (doc, loc) | `Doc (doc, loc)) -> let ast_docs = Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:doc From 476df662f85c73614a59beef5a46861e501d8a26 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Wed, 29 Apr 2026 15:40:46 +0200 Subject: [PATCH 03/13] Emit `cut` only if `zero_alloc` will be printed --- src/document/generator.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 53050e7d31..7408516452 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -990,7 +990,7 @@ module Make (Syntax : SYNTAX) = struct let name = Paths.Identifier.name t.id in let zero_alloc = match List.mem Odoc_model.Lang.Value.Zero_alloc t.ext_attr with - | true -> O.txt " " ++ O.txt "[@@zero_alloc]" + | true -> O.cut ++ O.txt " " ++ O.txt "[@@zero_alloc]" | false -> O.noop in let content = @@ -1000,7 +1000,7 @@ module Make (Syntax : SYNTAX) = struct ++ O.txt " " ++ O.txt name ++ O.txt Syntax.Type.annotation_separator ++ O.cut ++ type_expr t.type_ - ++ O.cut ++ zero_alloc + ++ zero_alloc ++ if semicolon then O.txt ";" else O.noop) in let attr = [ "value" ] @ extra_attr in From 4ae99296cdae910b99547d320145fbc98d72b867 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Fri, 1 May 2026 14:26:11 +0200 Subject: [PATCH 04/13] Preserve `zero_alloc strict` and `zero_alloc opt` arguments --- src/document/generator.ml | 12 +++++++--- src/loader/doc_attr.ml | 38 ++++++++++++++++++++++++++---- src/model/lang.ml | 6 ++++- test/generators/cases/oxcaml.mli | 8 +++++++ test/generators/html/Oxcaml.html | 32 +++++++++++++++++++++++++ test/generators/latex/Oxcaml.tex | 4 ++++ test/generators/man/Oxcaml.3o | 14 +++++++++++ test/generators/markdown/Oxcaml.md | 10 ++++++++ 8 files changed, 116 insertions(+), 8 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 7408516452..75d61b3ee4 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -989,9 +989,15 @@ module Make (Syntax : SYNTAX) = struct in let name = Paths.Identifier.name t.id in let zero_alloc = - match List.mem Odoc_model.Lang.Value.Zero_alloc t.ext_attr with - | true -> O.cut ++ O.txt " " ++ O.txt "[@@zero_alloc]" - | false -> O.noop + match List.find (function Odoc_model.Lang.Value.Zero_alloc _ -> true) t.ext_attr with + | Zero_alloc alloc_type -> + let alloc_type = match alloc_type with + | Assume -> "" + | Strict -> " strict" + | Opt -> " opt" + in + O.cut ++ O.txt " " ++ O.txt (Printf.sprintf "[@@zero_alloc%s]" alloc_type) + | exception Not_found -> O.noop in let content = O.documentedSrc diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index 610938c59f..ea0e5edd1e 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -74,11 +74,41 @@ let attribute_unpack = function | { Location.txt = name; loc }, attr_payload -> (name, attr_payload, loc) #endif +let ident (pexp_desc : Parsetree.expression_desc) = + match pexp_desc with + | Pexp_ident {txt=longident; _} -> ( + match longident with + | Lident s -> Some s + | _ -> None) + | _ -> None + +let zero_alloc_structure_arg (pstr_desc: Parsetree.structure_item_desc) = + match pstr_desc with + | Pstr_eval ({pexp_desc; _}, _) -> ( + (* check if this is strict or opt *) + match ident pexp_desc with + | Some "strict" -> Some Lang.Value.Zero_alloc.Strict + | Some "opt" -> Some Lang.Value.Zero_alloc.Opt + | _ -> None) + | _ -> None + +let zero_alloc_argument (payload : Parsetree.payload) = + match payload with + | PStr structure_items -> ( + match structure_items with + | [] -> Some Lang.Value.Zero_alloc.Assume + | [{pstr_desc; _}] -> zero_alloc_structure_arg pstr_desc + | _ -> None) + | _ -> None + let known_attribute attr = - let name, _, _ = attribute_unpack attr in - match String.equal name "zero_alloc" with - | true -> Some Lang.Value.Zero_alloc - | false -> None + let name, payload, _ = attribute_unpack attr in + match name with + | "zero_alloc" -> ( + match zero_alloc_argument payload with + | Some zalloc_type -> Some (Lang.Value.Zero_alloc zalloc_type) + | None -> None) + | _ -> None type payload = string * Location.t diff --git a/src/model/lang.ml b/src/model/lang.ml index fedde646b7..9a79b9b324 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -320,7 +320,11 @@ end = and Value : sig type value = Abstract | External of string list - type attr = Zero_alloc + + module Zero_alloc : sig + type t = Assume | Opt | Strict + end + type attr = Zero_alloc of Zero_alloc.t type t = { id : Identifier.Value.t; diff --git a/test/generators/cases/oxcaml.mli b/test/generators/cases/oxcaml.mli index ea697c78cc..4fa769b0ad 100644 --- a/test/generators/cases/oxcaml.mli +++ b/test/generators/cases/oxcaml.mli @@ -5,3 +5,11 @@ val add : bool -> int -> int -> int [@@zero_alloc] (** Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero_alloc_check/ *) + +val add_opt : bool -> int -> int -> int [@@zero_alloc opt] +(** Like [add] but with an [opt] attribute. + *) + +val add_strict : bool -> int -> int -> int [@@zero_alloc strict] +(** Like [add] but with a [strict] attribute. + *) diff --git a/test/generators/html/Oxcaml.html b/test/generators/html/Oxcaml.html index e22dc624ad..00c3908e90 100644 --- a/test/generators/html/Oxcaml.html +++ b/test/generators/html/Oxcaml.html @@ -53,6 +53,38 @@

Module Oxcaml

+
+
+ + + val add_opt : + bool -> + int -> + int -> int + [@@zero_alloc opt] + + +
+
+

Like add but with an opt attribute.

+
+
+
+
+ + + val add_strict : + bool -> + int -> + int -> int + [@@zero_alloc strict] + + +
+
+

Like add but with a strict attribute.

+
+
diff --git a/test/generators/latex/Oxcaml.tex b/test/generators/latex/Oxcaml.tex index de027ca4c5..3d6cea187a 100644 --- a/test/generators/latex/Oxcaml.tex +++ b/test/generators/latex/Oxcaml.tex @@ -3,5 +3,9 @@ \section{Module \ocamlinlinecode{Oxcaml}}\label{Oxcaml}% \medbreak \label{Oxcaml--val-add}\ocamlcodefragment{\ocamltag{keyword}{val} add : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc]}\begin{ocamlindent}Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero\_alloc\_check/\end{ocamlindent}% \medbreak +\label{Oxcaml--val-add_opt}\ocamlcodefragment{\ocamltag{keyword}{val} add\_\allowbreak{}opt : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc opt]}\begin{ocamlindent}Like \ocamlinlinecode{add} but with an \ocamlinlinecode{opt} attribute.\end{ocamlindent}% +\medbreak +\label{Oxcaml--val-add_strict}\ocamlcodefragment{\ocamltag{keyword}{val} add\_\allowbreak{}strict : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc strict]}\begin{ocamlindent}Like \ocamlinlinecode{add} but with a \ocamlinlinecode{strict} attribute.\end{ocamlindent}% +\medbreak diff --git a/test/generators/man/Oxcaml.3o b/test/generators/man/Oxcaml.3o index 3a67286f28..55e91911ce 100644 --- a/test/generators/man/Oxcaml.3o +++ b/test/generators/man/Oxcaml.3o @@ -24,4 +24,18 @@ Polymorphic arguments require parentheses .ti +2 Zero allocation bindings have an extension attribute attached\. See https://oxcaml\.org/documentation/miscellaneous-extensions/zero_alloc_check/ .nf +.sp +\f[CB]val\fR add_opt : bool \f[CB]\->\fR int \f[CB]\->\fR int \f[CB]\->\fR int [@@zero_alloc opt] +.fi +.br +.ti +2 +Like add but with an opt attribute\. +.nf +.sp +\f[CB]val\fR add_strict : bool \f[CB]\->\fR int \f[CB]\->\fR int \f[CB]\->\fR int [@@zero_alloc strict] +.fi +.br +.ti +2 +Like add but with a strict attribute\. +.nf diff --git a/test/generators/markdown/Oxcaml.md b/test/generators/markdown/Oxcaml.md index 7a57168476..6575c8dda5 100644 --- a/test/generators/markdown/Oxcaml.md +++ b/test/generators/markdown/Oxcaml.md @@ -10,3 +10,13 @@ Polymorphic arguments require parentheses val add : bool -> int -> int -> int [@@zero_alloc] ``` Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero\_alloc\_check/ + +```ocaml +val add_opt : bool -> int -> int -> int [@@zero_alloc opt] +``` +Like `add` but with an `opt` attribute. + +```ocaml +val add_strict : bool -> int -> int -> int [@@zero_alloc strict] +``` +Like `add` but with a `strict` attribute. From 55a6e899782ce1908f1822782a14488dfe7536d5 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Fri, 1 May 2026 14:44:40 +0200 Subject: [PATCH 05/13] Reformat --- src/document/generator.ml | 23 ++++++++++++++--------- src/odoc/extract_code.mli | 2 +- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 75d61b3ee4..97861422f5 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -989,14 +989,20 @@ module Make (Syntax : SYNTAX) = struct in let name = Paths.Identifier.name t.id in let zero_alloc = - match List.find (function Odoc_model.Lang.Value.Zero_alloc _ -> true) t.ext_attr with + match + List.find + (function Odoc_model.Lang.Value.Zero_alloc _ -> true) + t.ext_attr + with | Zero_alloc alloc_type -> - let alloc_type = match alloc_type with - | Assume -> "" - | Strict -> " strict" - | Opt -> " opt" - in - O.cut ++ O.txt " " ++ O.txt (Printf.sprintf "[@@zero_alloc%s]" alloc_type) + let alloc_type = + match alloc_type with + | Assume -> "" + | Strict -> " strict" + | Opt -> " opt" + in + O.cut ++ O.txt " " + ++ O.txt (Printf.sprintf "[@@zero_alloc%s]" alloc_type) | exception Not_found -> O.noop in let content = @@ -1005,8 +1011,7 @@ module Make (Syntax : SYNTAX) = struct @@ O.keyword Syntax.Value.variable_keyword ++ O.txt " " ++ O.txt name ++ O.txt Syntax.Type.annotation_separator - ++ O.cut ++ type_expr t.type_ - ++ zero_alloc + ++ O.cut ++ type_expr t.type_ ++ zero_alloc ++ if semicolon then O.txt ";" else O.noop) in let attr = [ "value" ] @ extra_attr in diff --git a/src/odoc/extract_code.mli b/src/odoc/extract_code.mli index f350e174a9..8c93d088a2 100644 --- a/src/odoc/extract_code.mli +++ b/src/odoc/extract_code.mli @@ -1,5 +1,5 @@ (** [extract ~dst ~input ~names ~line_directives ~warnings_options] extracts source code from document blocks. - @arg dst File path to write to *) + @param dst File path to write to *) val extract : dst:string option -> input:string -> From 7758f410e53fc3a236f42dc5ec83be56f366190d Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Mon, 4 May 2026 15:39:56 +0200 Subject: [PATCH 06/13] Add test for `val[@zero_alloc]` annotation --- test/generators/cases/oxcaml.mli | 3 +++ test/generators/html/Oxcaml.html | 32 ++++++++++++------------------ test/generators/latex/Oxcaml.tex | 4 ++-- test/generators/man/Oxcaml.3o | 14 ++++++------- test/generators/markdown/Oxcaml.md | 10 +++++----- 5 files changed, 30 insertions(+), 33 deletions(-) diff --git a/test/generators/cases/oxcaml.mli b/test/generators/cases/oxcaml.mli index 4fa769b0ad..d497c6fd0f 100644 --- a/test/generators/cases/oxcaml.mli +++ b/test/generators/cases/oxcaml.mli @@ -13,3 +13,6 @@ val add_opt : bool -> int -> int -> int [@@zero_alloc opt] val add_strict : bool -> int -> int -> int [@@zero_alloc strict] (** Like [add] but with a [strict] attribute. *) + +val[@zero_alloc] f : int -> int +(** Alternative syntax for zero alloc annotation *) diff --git a/test/generators/html/Oxcaml.html b/test/generators/html/Oxcaml.html index 00c3908e90..e886c0d20f 100644 --- a/test/generators/html/Oxcaml.html +++ b/test/generators/html/Oxcaml.html @@ -15,25 +15,6 @@

Module Oxcaml

-
-
- - - val f : - int -> - - ('a. - 'a - -> - 'a) - -> - unit - - -
-

Polymorphic arguments require parentheses

-
-
@@ -85,6 +66,19 @@

Module Oxcaml

Like add but with a strict attribute.

+
+
+ + + val f : + int -> int + [@@zero_alloc] + + +
+

Alternative syntax for zero alloc annotation

+
+
diff --git a/test/generators/latex/Oxcaml.tex b/test/generators/latex/Oxcaml.tex index 3d6cea187a..5329a4154d 100644 --- a/test/generators/latex/Oxcaml.tex +++ b/test/generators/latex/Oxcaml.tex @@ -1,11 +1,11 @@ \section{Module \ocamlinlinecode{Oxcaml}}\label{Oxcaml}% -\label{Oxcaml--val-f}\ocamlcodefragment{\ocamltag{keyword}{val} f : int \ocamltag{arrow}{$\rightarrow$} ('a.\allowbreak{} \ocamltag{type-var}{'a} \ocamltag{arrow}{$\rightarrow$} \ocamltag{type-var}{'a}) \ocamltag{arrow}{$\rightarrow$} unit}\begin{ocamlindent}Polymorphic arguments require parentheses\end{ocamlindent}% -\medbreak \label{Oxcaml--val-add}\ocamlcodefragment{\ocamltag{keyword}{val} add : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc]}\begin{ocamlindent}Zero allocation bindings have an extension attribute attached. See https://oxcaml.org/documentation/miscellaneous-extensions/zero\_alloc\_check/\end{ocamlindent}% \medbreak \label{Oxcaml--val-add_opt}\ocamlcodefragment{\ocamltag{keyword}{val} add\_\allowbreak{}opt : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc opt]}\begin{ocamlindent}Like \ocamlinlinecode{add} but with an \ocamlinlinecode{opt} attribute.\end{ocamlindent}% \medbreak \label{Oxcaml--val-add_strict}\ocamlcodefragment{\ocamltag{keyword}{val} add\_\allowbreak{}strict : bool \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc strict]}\begin{ocamlindent}Like \ocamlinlinecode{add} but with a \ocamlinlinecode{strict} attribute.\end{ocamlindent}% \medbreak +\label{Oxcaml--val-f}\ocamlcodefragment{\ocamltag{keyword}{val} f : int \ocamltag{arrow}{$\rightarrow$} int [@@zero\_\allowbreak{}alloc]}\begin{ocamlindent}Alternative syntax for zero alloc annotation\end{ocamlindent}% +\medbreak diff --git a/test/generators/man/Oxcaml.3o b/test/generators/man/Oxcaml.3o index 55e91911ce..19643aaddf 100644 --- a/test/generators/man/Oxcaml.3o +++ b/test/generators/man/Oxcaml.3o @@ -11,13 +11,6 @@ Oxcaml .SH Documentation .sp .nf -\f[CB]val\fR f : int \f[CB]\->\fR ('a\. \f[CB]'a\fR \f[CB]\->\fR \f[CB]'a\fR) \f[CB]\->\fR unit -.fi -.br -.ti +2 -Polymorphic arguments require parentheses -.nf -.sp \f[CB]val\fR add : bool \f[CB]\->\fR int \f[CB]\->\fR int \f[CB]\->\fR int [@@zero_alloc] .fi .br @@ -38,4 +31,11 @@ Like add but with an opt attribute\. .ti +2 Like add but with a strict attribute\. .nf +.sp +\f[CB]val\fR f : int \f[CB]\->\fR int [@@zero_alloc] +.fi +.br +.ti +2 +Alternative syntax for zero alloc annotation +.nf diff --git a/test/generators/markdown/Oxcaml.md b/test/generators/markdown/Oxcaml.md index 6575c8dda5..89903768ba 100644 --- a/test/generators/markdown/Oxcaml.md +++ b/test/generators/markdown/Oxcaml.md @@ -1,11 +1,6 @@ # Module `Oxcaml` -```ocaml -val f : int -> ('a. 'a -> 'a) -> unit -``` -Polymorphic arguments require parentheses - ```ocaml val add : bool -> int -> int -> int [@@zero_alloc] ``` @@ -20,3 +15,8 @@ Like `add` but with an `opt` attribute. val add_strict : bool -> int -> int -> int [@@zero_alloc strict] ``` Like `add` but with a `strict` attribute. + +```ocaml +val f : int -> int [@@zero_alloc] +``` +Alternative syntax for zero alloc annotation From 3eff2ba08abdbb013aa3a7bb0c62be3c6fe1f530 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Mon, 4 May 2026 15:42:19 +0200 Subject: [PATCH 07/13] Treat `zero_alloc` only special in OxCaml --- src/loader/doc_attr.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index ea0e5edd1e..28c15871ac 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -104,10 +104,12 @@ let zero_alloc_argument (payload : Parsetree.payload) = let known_attribute attr = let name, payload, _ = attribute_unpack attr in match name with +#if defined OXCAML | "zero_alloc" -> ( match zero_alloc_argument payload with | Some zalloc_type -> Some (Lang.Value.Zero_alloc zalloc_type) | None -> None) +#endif | _ -> None type payload = string * Location.t From c8f5577b1654b8ff18701f017892bbd18a72754c Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Wed, 6 May 2026 11:51:06 +0200 Subject: [PATCH 08/13] Parse more of zero_alloc annotation --- src/document/generator.ml | 26 +++++++++----- src/loader/doc_attr.ml | 71 +++++++++++++++++++++++++++++++++------ src/model/lang.ml | 10 +++++- 3 files changed, 86 insertions(+), 21 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 97861422f5..a0d18d551f 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -994,16 +994,24 @@ module Make (Syntax : SYNTAX) = struct (function Odoc_model.Lang.Value.Zero_alloc _ -> true) t.ext_attr with - | Zero_alloc alloc_type -> - let alloc_type = - match alloc_type with - | Assume -> "" - | Strict -> " strict" - | Opt -> " opt" - in - O.cut ++ O.txt " " - ++ O.txt (Printf.sprintf "[@@zero_alloc%s]" alloc_type) | exception Not_found -> O.noop + | Zero_alloc Ignore -> O.noop + | Zero_alloc (Respect {opt; strict; arity; custom_error_message}) -> + let ext_arg = match opt, strict with + | Some (), None -> " opt" + | None, Some () -> " strict" + | _, _ -> "" + in + let ext_arg = match arity with + | None -> ext_arg + | Some n -> ext_arg ^ (Printf.sprintf "arity %d" n) + in + let ext_arg = match custom_error_message with + | None -> ext_arg + | Some s -> ext_arg ^ (Printf.sprintf "custom_error_message %S" s) + in + let ext_attr = Printf.sprintf "[@@zero_alloc%s]" ext_arg in + O.cut ++ O.txt " " ++ O.txt ext_attr in let content = O.documentedSrc diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index 28c15871ac..3192d77ffa 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -85,20 +85,69 @@ let ident (pexp_desc : Parsetree.expression_desc) = let zero_alloc_structure_arg (pstr_desc: Parsetree.structure_item_desc) = match pstr_desc with | Pstr_eval ({pexp_desc; _}, _) -> ( - (* check if this is strict or opt *) match ident pexp_desc with - | Some "strict" -> Some Lang.Value.Zero_alloc.Strict - | Some "opt" -> Some Lang.Value.Zero_alloc.Opt + | (Some "arity") + | (Some "custom_error_message") + | (Some "ignore") + | (Some "strict") + | (Some "opt") as v -> v | _ -> None) | _ -> None -let zero_alloc_argument (payload : Parsetree.payload) = +let constant_of_expression (pexp_desc : Parsetree.expression_desc) = + match pexp_desc with + | Pexp_constant (Pconst_integer (i, _)) -> Some (`Integer (int_of_string i)) + | Pexp_constant (Pconst_string (s, _, _)) -> Some (`String s) + | _ -> None + +let zero_alloc_argument_arg (pstr_desc : Parsetree.structure_item_desc) = + match pstr_desc with + | Pstr_eval ({pexp_desc; _}, _) -> constant_of_expression pexp_desc + | _ -> None + +let rec zero_alloc_structure_item so_far (structure_items : Parsetree.structure) = + match structure_items with + | [] -> so_far + | {pstr_desc; _} :: structure_items -> + match so_far with + | Lang.Value.Zero_alloc.Ignore -> Ignore + | Respect respect -> + match zero_alloc_structure_arg pstr_desc with + | None -> so_far + | Some "ignore" -> Lang.Value.Zero_alloc.Ignore + | Some "strict" -> + let so_far = Lang.Value.Zero_alloc.Respect {respect with strict = Some ()} in + zero_alloc_structure_item so_far structure_items + | Some "opt" -> + let so_far = Lang.Value.Zero_alloc.Respect {respect with opt = Some ()} in + zero_alloc_structure_item so_far structure_items + | Some "arity" -> ( + match structure_items with + | [] -> so_far + | {pstr_desc; _} :: structure_items -> ( + match zero_alloc_argument_arg pstr_desc with + | Some (`Integer n) -> + let arity = Some n in + let so_far = Lang.Value.Zero_alloc.Respect {respect with arity} in + zero_alloc_structure_item so_far structure_items + | _ -> so_far)) + | Some "custom_error_message" -> ( + match structure_items with + | [] -> so_far + | {pstr_desc; _} :: structure_items -> ( + match zero_alloc_argument_arg pstr_desc with + | Some (`String s) -> + let custom_error_message = Some s in + let so_far = Lang.Value.Zero_alloc.Respect {respect with custom_error_message} in + zero_alloc_structure_item so_far structure_items + | _ -> so_far)) + | Some _ -> so_far + +let zero_alloc_arguments (payload : Parsetree.payload) = match payload with - | PStr structure_items -> ( - match structure_items with - | [] -> Some Lang.Value.Zero_alloc.Assume - | [{pstr_desc; _}] -> zero_alloc_structure_arg pstr_desc - | _ -> None) + | PStr structure_items -> + let so_far = Lang.Value.Zero_alloc.Respect { opt = None; strict = None; arity = None; custom_error_message = None} in + Some (zero_alloc_structure_item so_far structure_items) | _ -> None let known_attribute attr = @@ -106,8 +155,8 @@ let known_attribute attr = match name with #if defined OXCAML | "zero_alloc" -> ( - match zero_alloc_argument payload with - | Some zalloc_type -> Some (Lang.Value.Zero_alloc zalloc_type) + match zero_alloc_arguments payload with + | Some zalloc_arg -> Some (Lang.Value.Zero_alloc zalloc_arg) | None -> None) #endif | _ -> None diff --git a/src/model/lang.ml b/src/model/lang.ml index 9a79b9b324..89f297f4b2 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -322,7 +322,15 @@ and Value : sig type value = Abstract | External of string list module Zero_alloc : sig - type t = Assume | Opt | Strict + type respect = { + opt : unit option; + strict : unit option; + arity : int option; + custom_error_message : string option + } + type t = + | Ignore + | Respect of respect end type attr = Zero_alloc of Zero_alloc.t From a63e476e9ccdf7c80f9330257df0c3a941c93b57 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Wed, 6 May 2026 16:32:29 +0200 Subject: [PATCH 09/13] Better names, structure and types --- src/loader/doc_attr.ml | 159 ++++++++++++++++++++++------------------- 1 file changed, 87 insertions(+), 72 deletions(-) diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index 3192d77ffa..d7002778a6 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -74,88 +74,103 @@ let attribute_unpack = function | { Location.txt = name; loc }, attr_payload -> (name, attr_payload, loc) #endif -let ident (pexp_desc : Parsetree.expression_desc) = - match pexp_desc with - | Pexp_ident {txt=longident; _} -> ( - match longident with - | Lident s -> Some s - | _ -> None) - | _ -> None - -let zero_alloc_structure_arg (pstr_desc: Parsetree.structure_item_desc) = - match pstr_desc with - | Pstr_eval ({pexp_desc; _}, _) -> ( - match ident pexp_desc with - | (Some "arity") - | (Some "custom_error_message") - | (Some "ignore") - | (Some "strict") - | (Some "opt") as v -> v - | _ -> None) - | _ -> None - -let constant_of_expression (pexp_desc : Parsetree.expression_desc) = - match pexp_desc with - | Pexp_constant (Pconst_integer (i, _)) -> Some (`Integer (int_of_string i)) - | Pexp_constant (Pconst_string (s, _, _)) -> Some (`String s) - | _ -> None - -let zero_alloc_argument_arg (pstr_desc : Parsetree.structure_item_desc) = - match pstr_desc with - | Pstr_eval ({pexp_desc; _}, _) -> constant_of_expression pexp_desc - | _ -> None - -let rec zero_alloc_structure_item so_far (structure_items : Parsetree.structure) = - match structure_items with - | [] -> so_far - | {pstr_desc; _} :: structure_items -> - match so_far with - | Lang.Value.Zero_alloc.Ignore -> Ignore - | Respect respect -> - match zero_alloc_structure_arg pstr_desc with - | None -> so_far - | Some "ignore" -> Lang.Value.Zero_alloc.Ignore - | Some "strict" -> +module Zero_alloc = struct + let constant_of_expression (pexp_desc : Parsetree.expression_desc) = + match pexp_desc with + | Pexp_constant (Pconst_integer (i, _)) -> Some (`Integer (int_of_string i)) + | Pexp_constant (Pconst_string (s, _, _)) -> Some (`String s) + | _ -> None + + let parse_argument_of_keyword (pstr_desc : Parsetree.structure_item_desc) = + match pstr_desc with + | Pstr_eval ({pexp_desc; _}, _) -> constant_of_expression pexp_desc + | _ -> None + + let identifier_of_expression (pexp_desc : Parsetree.expression_desc) = + match pexp_desc with + | Pexp_ident {txt=longident; _} -> ( + match longident with + | Lident s -> Some s + | _ -> None) + | _ -> None + + let keyword_of_structure_arg (pstr_desc: Parsetree.structure_item_desc) = + match pstr_desc with + | Pstr_eval ({pexp_desc; _}, _) -> ( + match identifier_of_expression pexp_desc with + | Some "arity" -> Some `Arity + | Some "custom_error_message" -> Some `Custom_error_message + | Some "ignore" -> Some `Ignore + | Some "strict" -> Some `Strict + | Some "opt" -> Some `Opt + | _ -> None) + | _ -> None + + let rec arguments_of_structure_items so_far (structure_items : Parsetree.structure) = + match structure_items with + | [] -> so_far + | {pstr_desc; _} :: structure_items -> + match (so_far : Lang.Value.Zero_alloc.t) with + | Ignore -> Ignore + | Respect respect -> + match keyword_of_structure_arg pstr_desc with + | None -> so_far + | Some `Ignore -> Lang.Value.Zero_alloc.Ignore + | Some `Strict -> let so_far = Lang.Value.Zero_alloc.Respect {respect with strict = Some ()} in - zero_alloc_structure_item so_far structure_items - | Some "opt" -> + arguments_of_structure_items so_far structure_items + | Some `Opt -> let so_far = Lang.Value.Zero_alloc.Respect {respect with opt = Some ()} in - zero_alloc_structure_item so_far structure_items - | Some "arity" -> ( + arguments_of_structure_items so_far structure_items + | Some `Arity -> ( match structure_items with - | [] -> so_far + | [] -> + (* this is an error *) + so_far | {pstr_desc; _} :: structure_items -> ( - match zero_alloc_argument_arg pstr_desc with - | Some (`Integer n) -> - let arity = Some n in - let so_far = Lang.Value.Zero_alloc.Respect {respect with arity} in - zero_alloc_structure_item so_far structure_items - | _ -> so_far)) - | Some "custom_error_message" -> ( - match structure_items with - | [] -> so_far - | {pstr_desc; _} :: structure_items -> ( - match zero_alloc_argument_arg pstr_desc with - | Some (`String s) -> - let custom_error_message = Some s in - let so_far = Lang.Value.Zero_alloc.Respect {respect with custom_error_message} in - zero_alloc_structure_item so_far structure_items - | _ -> so_far)) - | Some _ -> so_far - -let zero_alloc_arguments (payload : Parsetree.payload) = - match payload with - | PStr structure_items -> - let so_far = Lang.Value.Zero_alloc.Respect { opt = None; strict = None; arity = None; custom_error_message = None} in - Some (zero_alloc_structure_item so_far structure_items) - | _ -> None + match parse_argument_of_keyword pstr_desc with + | Some (`Integer n) -> + let arity = Some n in + let so_far = Lang.Value.Zero_alloc.Respect {respect with arity} in + arguments_of_structure_items so_far structure_items + | _ -> + (* this is an error *) + so_far)) + | Some `Custom_error_message -> ( + match structure_items with + | [] -> + (* this is an error *) + so_far + | {pstr_desc; _} :: structure_items -> ( + match parse_argument_of_keyword pstr_desc with + | Some (`String s) -> + let custom_error_message = Some s in + let so_far = Lang.Value.Zero_alloc.Respect {respect with custom_error_message} in + arguments_of_structure_items so_far structure_items + | _ -> + (* this is an error *) + so_far)) + + let arguments_of_payload (payload : Parsetree.payload) = + match payload with + | PStr structure_items -> + (* start with completely empty arguments *) + let so_far = Lang.Value.Zero_alloc.Respect { + opt = None; + strict = None; + arity = None; + custom_error_message = None} + in + Some (arguments_of_structure_items so_far structure_items) + | _ -> None +end let known_attribute attr = let name, payload, _ = attribute_unpack attr in match name with #if defined OXCAML | "zero_alloc" -> ( - match zero_alloc_arguments payload with + match Zero_alloc.arguments_of_payload payload with | Some zalloc_arg -> Some (Lang.Value.Zero_alloc zalloc_arg) | None -> None) #endif From 0a57c88cd2e00c6ba13cb83465b61cd8b12957bb Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 7 May 2026 15:35:27 +0200 Subject: [PATCH 10/13] Reformat --- src/document/generator.ml | 9 ++++++--- src/odoc/extract_code.mli | 3 ++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index a0d18d551f..c7bbc50037 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -997,16 +997,19 @@ module Make (Syntax : SYNTAX) = struct | exception Not_found -> O.noop | Zero_alloc Ignore -> O.noop | Zero_alloc (Respect {opt; strict; arity; custom_error_message}) -> - let ext_arg = match opt, strict with + let ext_arg = + match opt, strict with | Some (), None -> " opt" | None, Some () -> " strict" | _, _ -> "" in - let ext_arg = match arity with + let ext_arg = + match arity with | None -> ext_arg | Some n -> ext_arg ^ (Printf.sprintf "arity %d" n) in - let ext_arg = match custom_error_message with + let ext_arg = + match custom_error_message with | None -> ext_arg | Some s -> ext_arg ^ (Printf.sprintf "custom_error_message %S" s) in diff --git a/src/odoc/extract_code.mli b/src/odoc/extract_code.mli index 8c93d088a2..64dc970212 100644 --- a/src/odoc/extract_code.mli +++ b/src/odoc/extract_code.mli @@ -1,4 +1,5 @@ -(** [extract ~dst ~input ~names ~line_directives ~warnings_options] extracts source code from document blocks. +(** [extract ~dst ~input ~names ~line_directives ~warnings_options] extracts + source code from document blocks. @param dst File path to write to *) val extract : dst:string option -> From 9cdf648b8f4b9d28ef2c9fbfb16a674b496d9d60 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 7 May 2026 15:37:17 +0200 Subject: [PATCH 11/13] fixup! Reformat --- src/model/lang.ml | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/model/lang.ml b/src/model/lang.ml index 89f297f4b2..80e5a0e76a 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -323,14 +323,12 @@ and Value : sig module Zero_alloc : sig type respect = { - opt : unit option; - strict : unit option; - arity : int option; - custom_error_message : string option - } - type t = - | Ignore - | Respect of respect + opt : unit option; + strict : unit option; + arity : int option; + custom_error_message : string option + } + type t = Ignore | Respect of respect end type attr = Zero_alloc of Zero_alloc.t From a552fa1807b453bbf869d80221b1f048e59945b9 Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 7 May 2026 15:40:55 +0200 Subject: [PATCH 12/13] fixup! fixup! Reformat --- src/document/generator.ml | 8 ++++---- src/model/lang.ml | 2 +- src/odoc/extract_code.mli | 3 --- 3 files changed, 5 insertions(+), 8 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index c7bbc50037..a75ee93fda 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -996,9 +996,9 @@ module Make (Syntax : SYNTAX) = struct with | exception Not_found -> O.noop | Zero_alloc Ignore -> O.noop - | Zero_alloc (Respect {opt; strict; arity; custom_error_message}) -> + | Zero_alloc (Respect { opt; strict; arity; custom_error_message }) -> let ext_arg = - match opt, strict with + match (opt, strict) with | Some (), None -> " opt" | None, Some () -> " strict" | _, _ -> "" @@ -1006,12 +1006,12 @@ module Make (Syntax : SYNTAX) = struct let ext_arg = match arity with | None -> ext_arg - | Some n -> ext_arg ^ (Printf.sprintf "arity %d" n) + | Some n -> ext_arg ^ Printf.sprintf "arity %d" n in let ext_arg = match custom_error_message with | None -> ext_arg - | Some s -> ext_arg ^ (Printf.sprintf "custom_error_message %S" s) + | Some s -> ext_arg ^ Printf.sprintf "custom_error_message %S" s in let ext_attr = Printf.sprintf "[@@zero_alloc%s]" ext_arg in O.cut ++ O.txt " " ++ O.txt ext_attr diff --git a/src/model/lang.ml b/src/model/lang.ml index 80e5a0e76a..40ee9abbdd 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -326,7 +326,7 @@ and Value : sig opt : unit option; strict : unit option; arity : int option; - custom_error_message : string option + custom_error_message : string option; } type t = Ignore | Respect of respect end diff --git a/src/odoc/extract_code.mli b/src/odoc/extract_code.mli index 64dc970212..263ce49cc3 100644 --- a/src/odoc/extract_code.mli +++ b/src/odoc/extract_code.mli @@ -1,6 +1,3 @@ -(** [extract ~dst ~input ~names ~line_directives ~warnings_options] extracts - source code from document blocks. - @param dst File path to write to *) val extract : dst:string option -> input:string -> From 9ff49826c4988e2192a060349146486e28e8f8ec Mon Sep 17 00:00:00 2001 From: Marek Kubica Date: Thu, 7 May 2026 15:42:44 +0200 Subject: [PATCH 13/13] Add PR number --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index bbc5b1074c..fc738ea551 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,7 +6,7 @@ invocation, eliminating the need for shell scripting (@davesnx, #1387) - Support for OxCaml (@lukemaurer, @art-w, #1399) - OCaml 5.5.0 support (@panglesd, @xvw, #1406) -- Support for OxCaml zero alloc definitions (@Leonidas-from-XIV, #) +- Support for OxCaml zero alloc definitions (@Leonidas-from-XIV, #1422) ### Fixed - Fix compile-time crashing bugs #930 and #1385 (@jonludlam, #1400)