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
(* Js_of_ocaml compiler
 * http://www.ocsigen.org/js_of_ocaml/
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)
open! Stdlib

let aliases_ = String.Hashtbl.create 17

let rec resolve nm = try resolve (String.Hashtbl.find aliases_ nm) with Not_found -> nm

(****)

type kind =
  [ `Pure
  | `Mutable
  | `Mutator
  ]

let kind_equal (a : kind) b = Poly.equal a b

type kind_arg =
  [ `Shallow_const
  | `Object_literal
  | `Const
  | `Mutable
  ]

type condition =
  [ `If of string
  | `Ifnot of string
  ]

type t =
  [ `Requires of string list
  | `Provides of string * kind * kind_arg list option
  | `Version of ((int -> int -> bool) * string) list
  | `Weakdef
  | `Always
  | `Alias of string
  | `Deprecated of string
  | condition
  ]

let string_of_kind = function
  | `Pure -> "pure"
  | `Mutable -> "mutable"
  | `Mutator -> "mutator"

let kinds = String.Hashtbl.create 37

let kind_args_tbl = String.Hashtbl.create 37

let arities = String.Hashtbl.create 37

let kind nm = try String.Hashtbl.find kinds (resolve nm) with Not_found -> `Mutator

let kind_args nm =
  try Some (String.Hashtbl.find kind_args_tbl (resolve nm)) with Not_found -> None

let arity nm = String.Hashtbl.find arities (resolve nm)

let has_arity nm a =
  try String.Hashtbl.find arities (resolve nm) = a with Not_found -> false

let is_pure nm =
  match nm with
  | "%identity" | "%direct_int_div" | "%direct_int_mod" | "%direct_int_mul" -> true
  | _ -> (
      match kind nm with
      | `Mutator -> false
      | `Mutable | `Pure -> true)

let exists p = String.Hashtbl.mem kinds p

let externals = ref StringSet.empty

let add_external name = externals := StringSet.add name !externals

let get_external () = !externals

let register p k kargs arity =
  (match String.Hashtbl.find kinds (resolve p) with
  | exception Not_found -> ()
  | k' when kind_equal k k' -> ()
  | k' ->
      Warning.warn
        `Overriding_primitive_purity
        "overriding the purity of the primitive %s: %s -> %s@."
        p
        (string_of_kind k')
        (string_of_kind k));
  add_external p;
  (match arity with
  | Some a -> String.Hashtbl.replace arities p a
  | _ -> ());
  (match kargs with
  | Some k -> String.Hashtbl.replace kind_args_tbl p k
  | _ -> ());
  String.Hashtbl.replace kinds p k

let alias nm nm' =
  add_external nm';
  add_external nm;
  String.Hashtbl.replace aliases_ nm nm'

let aliases () = String.Hashtbl.to_seq aliases_ |> List.of_seq

let named_values = ref StringSet.empty

let need_named_value s = StringSet.mem s !named_values

let register_named_value s = named_values := StringSet.add s !named_values

let reset () =
  String.Hashtbl.clear kinds;
  String.Hashtbl.clear kind_args_tbl;
  String.Hashtbl.clear arities;
  String.Hashtbl.clear aliases_;
  named_values := StringSet.empty