Revision 1143fc9798ec6e5f58164caffdaca7178402e80b authored by Alain Mebsout on 16 November 2022, 15:55:34 UTC, committed by Alain Mebsout on 18 November 2022, 17:03:24 UTC
1 parent 9bd2352
function_type.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Api
open Vectors
type (_, _) params =
| End_param : ('r, 'r) params
| Trigger_param : ('a, 'r) params -> (unit -> 'a, 'r) params
| Cons_param : 'a Value_type.t * ('b, 'r) params -> ('a -> 'b, 'r) params
let num_params params =
let rec go : type f r. (f, r) params -> Unsigned.size_t -> Unsigned.size_t =
fun params num ->
match params with
| End_param -> num
| Trigger_param params -> (go [@tailcail]) params num
| Cons_param (_, params) ->
(go [@tailcail]) params (Unsigned.Size_t.succ num)
in
go params Unsigned.Size_t.zero
let param_types params =
let inputs = Value_type_vector.uninitialized (num_params params) in
let set_type index typ =
Value_type_vector.set inputs index (Value_type.to_valtype typ)
in
let rec go : type f r. (f, r) params -> int -> unit =
fun params index ->
match params with
| End_param -> ()
| Trigger_param params -> (go [@tailcail]) params index
| Cons_param (typ, params) ->
set_type index typ ;
(go [@tailcail]) params (succ index)
in
go params 0 ;
inputs
type _ results =
| No_result : unit results
| One_result : 'a Value_type.t -> 'a results
| Cons_result : 'a Value_type.t * 'b results -> ('a * 'b) results
let num_results results =
let rec go : type r. r results -> Unsigned.size_t -> Unsigned.size_t =
fun results num ->
match results with
| No_result -> num
| One_result _ -> Unsigned.Size_t.succ num
| Cons_result (_, results) ->
(go [@tailcail]) results (Unsigned.Size_t.succ num)
in
go results Unsigned.Size_t.zero
let result_types results =
let outputs = Value_type_vector.uninitialized (num_results results) in
let set_type index typ =
Value_type_vector.set outputs index (Value_type.to_valtype typ)
in
let rec go : type r. r results -> int -> unit =
fun results index ->
match results with
| No_result -> ()
| One_result typ -> set_type index typ
| Cons_result (typ, results) ->
set_type index typ ;
(go [@tailcail]) results (succ index)
in
go results 0 ;
outputs
type 'f t = Function : ('f, 'r Lwt.t) params * 'r results -> 'f t
let to_owned (Function (params, results)) =
let inputs = param_types params in
let outputs = result_types results in
(* Note, this consumes the elements in [inputs] and [outputs] but not the
structures themselves. Ctypes will free the structures once they go out
of scope. *)
Functions.Functype.new_ (Ctypes.addr inputs) (Ctypes.addr outputs)
exception
Wrong_number_of_params of {expected : Unsigned.size_t; got : Unsigned.size_t}
let () =
Printexc.register_printer (function
| Wrong_number_of_params {expected; got} ->
Some
(Printf.sprintf
"Wrong number of parameters: expected %s, got %s"
(Unsigned.Size_t.to_string expected)
(Unsigned.Size_t.to_string got))
| _ -> None)
let check_param_types params param_types =
let expected = num_params params in
let got = Value_type_vector.length param_types in
if
(* Fewer or more params than expected. *)
not (Unsigned.Size_t.equal expected got)
then raise (Wrong_number_of_params {got; expected}) ;
let rec go : type f r. (f, r) params -> int -> unit =
fun params index ->
match params with
| End_param -> ()
| Trigger_param params -> (go [@tailcail]) params index
| Cons_param (expected, params) ->
Value_type_vector.get param_types index |> Value_type.check expected ;
(go [@tailcail]) params (succ index)
in
go params 0
exception
Not_enough_results of {expected : Unsigned.size_t; got : Unsigned.size_t}
let () =
Printexc.register_printer (function
| Not_enough_results {expected; got} ->
Some
(Printf.sprintf
"Not enough results: expected %s, got %s"
(Unsigned.Size_t.to_string expected)
(Unsigned.Size_t.to_string got))
| _ -> None)
let check_result_types results result_types =
let expected = num_results results in
let got = Value_type_vector.length result_types in
if (* Fewer resuls than expected. *)
Unsigned.Size_t.compare got expected < 0
then raise (Not_enough_results {got; expected}) ;
let rec go : type r. r results -> int -> unit =
fun results index ->
match results with
| No_result -> ()
| One_result expected ->
Value_type_vector.get result_types index |> Value_type.check expected
| Cons_result (expected, results) ->
Value_type_vector.get result_types index |> Value_type.check expected ;
(go [@tailcail]) results (succ index)
in
go results 0
exception Function_type_mismatch of {reason : exn}
let () =
Printexc.register_printer (function
| Function_type_mismatch {reason} ->
Some
(Printf.sprintf
"Function type does not match: %s"
(Printexc.to_string reason))
| _ -> None)
let check_types (Function (params, results)) func_type =
try
let param_types = Functions.Functype.params func_type in
check_param_types params Ctypes.(!@param_types) ;
let result_types = Functions.Functype.results func_type in
check_result_types results Ctypes.(!@result_types)
with exn -> raise (Function_type_mismatch {reason = exn})
![swh spinner](/static/img/swh-spinner.gif)
Computing file changes ...