package merlin-lib
Merlin's libraries
Install
Dune Dependency
Authors
Maintainers
Sources
merlin-5.5-503.tbz
sha256=67da3b34f2fea07678267309f61da4a2c6f08298de0dc59655b8d30fd8269af1
sha512=1fb3b5180d36aa82b82a319e15b743b802b6888f0dc67645baafdb4e18dfc23a7b90064ec9bc42f7424061cf8cde7f8839178d8a8537bf4596759f3ff4891873
doc/src/merlin-lib.ocaml_typing/primitive.ml.html
Source file primitive.ml
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
(**************************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (* Description of primitive functions *) open Misc open Parsetree type boxed_integer = Pnativeint | Pint32 | Pint64 type native_repr = | Same_as_ocaml_repr | Unboxed_float | Unboxed_integer of boxed_integer | Untagged_immediate type description = { prim_name: string; (* Name of primitive or C function *) prim_arity: int; (* Number of arguments *) prim_alloc: bool; (* Does it allocates or raise? *) prim_native_name: string; (* Name of C function for the nat. code gen. *) prim_native_repr_args: native_repr list; prim_native_repr_res: native_repr } type error = | Old_style_float_with_native_repr_attribute | Old_style_noalloc_with_noalloc_attribute | No_native_primitive_with_repr_attribute exception Error of Location.t * error let is_ocaml_repr = function | Same_as_ocaml_repr -> true | Unboxed_float | Unboxed_integer _ | Untagged_immediate -> false let is_unboxed = function | Same_as_ocaml_repr | Untagged_immediate -> false | Unboxed_float | Unboxed_integer _ -> true let is_untagged = function | Untagged_immediate -> true | Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _ -> false let rec make_native_repr_args arity x = if arity = 0 then [] else x :: make_native_repr_args (arity - 1) x let simple ~name ~arity ~alloc = {prim_name = name; prim_arity = arity; prim_alloc = alloc; prim_native_name = ""; prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr; prim_native_repr_res = Same_as_ocaml_repr} let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res = {prim_name = name; prim_arity = List.length native_repr_args; prim_alloc = alloc; prim_native_name = native_name; prim_native_repr_args = native_repr_args; prim_native_repr_res = native_repr_res} let parse_declaration valdecl ~native_repr_args ~native_repr_res = let arity = List.length native_repr_args in let name, native_name, old_style_noalloc, old_style_float = match valdecl.pval_prim with | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true) | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false) | name :: name2 :: "float" :: _ -> (name, name2, false, true) | name :: "noalloc" :: _ -> (name, "", true, false) | name :: name2 :: _ -> (name, name2, false, false) | name :: _ -> (name, "", false, false) | [] -> fatal_error "Primitive.parse_declaration" in let noalloc_attribute = Attr_helper.has_no_payload_attribute "noalloc" valdecl.pval_attributes in if old_style_float && not (List.for_all is_ocaml_repr native_repr_args && is_ocaml_repr native_repr_res) then raise (Error (valdecl.pval_loc, Old_style_float_with_native_repr_attribute)); if old_style_noalloc && noalloc_attribute then raise (Error (valdecl.pval_loc, Old_style_noalloc_with_noalloc_attribute)); (* The compiler used to assume "noalloc" with "float", we just make this explicit now (GPR#167): *) let old_style_noalloc = old_style_noalloc || old_style_float in if old_style_float then Location.deprecated valdecl.pval_loc "[@@unboxed] + [@@noalloc] should be used\n\ instead of \"float\"" else if old_style_noalloc then Location.deprecated valdecl.pval_loc "[@@noalloc] should be used instead of \"noalloc\""; if native_name = "" && not (List.for_all is_ocaml_repr native_repr_args && is_ocaml_repr native_repr_res) then raise (Error (valdecl.pval_loc, No_native_primitive_with_repr_attribute)); let noalloc = old_style_noalloc || noalloc_attribute in let native_repr_args, native_repr_res = if old_style_float then (make_native_repr_args arity Unboxed_float, Unboxed_float) else (native_repr_args, native_repr_res) in {prim_name = name; prim_arity = arity; prim_alloc = not noalloc; prim_native_name = native_name; prim_native_repr_args = native_repr_args; prim_native_repr_res = native_repr_res} open Outcometree let rec add_native_repr_attributes ty attrs = match ty, attrs with | Otyp_arrow (label, a, b), attr_opt :: rest -> let b = add_native_repr_attributes b rest in let a = match attr_opt with | None -> a | Some attr -> Otyp_attribute (a, attr) in Otyp_arrow (label, a, b) | _, [Some attr] -> Otyp_attribute (ty, attr) | _ -> assert (List.for_all (fun x -> x = None) attrs); ty let oattr_unboxed = { oattr_name = "unboxed" } let oattr_untagged = { oattr_name = "untagged" } let oattr_noalloc = { oattr_name = "noalloc" } let print p osig_val_decl = let prims = if p.prim_native_name <> "" then [p.prim_name; p.prim_native_name] else [p.prim_name] in let for_all f = List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res in let all_unboxed = for_all is_unboxed in let all_untagged = for_all is_untagged in let attrs = if p.prim_alloc then [] else [oattr_noalloc] in let attrs = if all_unboxed then oattr_unboxed :: attrs else if all_untagged then oattr_untagged :: attrs else attrs in let attr_of_native_repr = function | Same_as_ocaml_repr -> None | Unboxed_float | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed | Untagged_immediate -> if all_untagged then None else Some oattr_untagged in let type_attrs = List.map attr_of_native_repr p.prim_native_repr_args @ [attr_of_native_repr p.prim_native_repr_res] in { osig_val_decl with oval_prims = prims; oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs; oval_attributes = attrs } let native_name p = if p.prim_native_name <> "" then p.prim_native_name else p.prim_name let byte_name p = p.prim_name let equal_boxed_integer bi1 bi2 = match bi1, bi2 with | Pnativeint, Pnativeint | Pint32, Pint32 | Pint64, Pint64 -> true | (Pnativeint | Pint32 | Pint64), _ -> false let equal_native_repr nr1 nr2 = match nr1, nr2 with | Same_as_ocaml_repr, Same_as_ocaml_repr -> true | Same_as_ocaml_repr, (Unboxed_float | Unboxed_integer _ | Untagged_immediate) -> false | Unboxed_float, Unboxed_float -> true | Unboxed_float, (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_immediate) -> false | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2 | Unboxed_integer _, (Same_as_ocaml_repr | Unboxed_float | Untagged_immediate) -> false | Untagged_immediate, Untagged_immediate -> true | Untagged_immediate, (Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _) -> false let native_name_is_external p = let nat_name = native_name p in nat_name <> "" && nat_name.[0] <> '%' module Style = Misc.Style let report_error ppf err = match err with | Old_style_float_with_native_repr_attribute -> Format_doc.fprintf ppf "Cannot use %a in conjunction with %a/%a." Style.inline_code "float" Style.inline_code "[@unboxed]" Style.inline_code "[@untagged]" | Old_style_noalloc_with_noalloc_attribute -> Format_doc.fprintf ppf "Cannot use %a in conjunction with %a." Style.inline_code "noalloc" Style.inline_code "[@@noalloc]" | No_native_primitive_with_repr_attribute -> Format_doc.fprintf ppf "@[The native code version of the primitive is mandatory@ \ when attributes %a or %a are present.@]" Style.inline_code "[@untagged]" Style.inline_code "[@unboxed]" let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (Location.error_of_printer ~loc report_error err) | _ -> None )
sectionYPositions = computeSectionYPositions($el), 10)"
x-init="setTimeout(() => sectionYPositions = computeSectionYPositions($el), 10)"
>