Skip to content
This repository
tag: v43
Fetching contributors…

Cannot retrieve contributors at this time

file 112 lines (90 sloc) 4.046 kb
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
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA 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 Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* alias *)
module FField = Flat_Runtime.Field
module VTable = Flat_Runtime.VTable

(*
Magic traduction, because ocaml does not accept friend modules
*)
external field_t_of_field : ServerLib.field -> FField.t = "%identity"
external field_of_field_t : FField.t -> ServerLib.field = "%identity"
external ty_record_of_record : Flat_Runtime.record -> ServerLib.ty_record = "%identity"
external record_of_ty_record : ServerLib.ty_record -> Flat_Runtime.record = "%identity"

(* this module isn't meant to be used directly, call DebugPrint.print instead *)
module Debug : sig end =
struct
  let check_vtable = VTable.check
  let check_record_repr (x:Obj.t) : bool =
    (Obj.tag x = 0) && (* array *)
    Obj.size x >= 2 && (* vtable + option + flattened fields *)
    check_vtable (Obj.field x 0) &&
    DebugPrint.option (Obj.field x 1) &&
    Obj.size x - 2 = Obj.size (Obj.field x 0) (* content and vtable have same size *)
    (* cant't check anything on the content *)
  let check_record (x:'a) : bool = check_record_repr (Obj.repr x)

  (* printing by inspection of the values *)
  let unsafe_print x =
    Printf.sprintf "{%s}"
      (ServerLib.fold_record
         (fun field obj acc ->
            let acc = if acc = "" then "" else acc^"; " in
            let name_field = FField.name (field_t_of_field field) in
            if Flat_Runtime.is_empty (Obj.magic obj)
            then Printf.sprintf "%s%s" acc name_field
            else Printf.sprintf "%s%s: %s" acc name_field (DebugPrint.print obj)
         )
         x
         "")
  let print_opt x =
    if check_record x then (
      if Flat_Runtime.is_empty (Obj.magic x) then
        Some "{}"
      else
        Some (unsafe_print x)
    ) else
      None
  let () = DebugPrint.register {DebugPrint.f = print_opt}
end

type flat_record = Flat_Runtime.flat_record

module Field =
struct
  type t = ServerLib.field
  let register f = field_of_field_t (FField.register f)
end

module FieldAccess = Flat_Runtime.FieldAccess

type record = ServerLib.ty_record

module Simple =
struct
  let register s = ty_record_of_record (Flat_Runtime.Simple.register s)
end

let runtime_error = Flat_Runtime.runtime_error
external unwrap_record : ServerLib.ty_record -> _ array = "%identity"

external get_vtable : ServerLib.ty_record -> VTable.t = "%field0"

let empty = ServerLib.empty_record

let true_ = ty_record_of_record Flat_Runtime.true_
let false_ = ty_record_of_record Flat_Runtime.false_

let wrap_bool b = ty_record_of_record (Flat_Runtime.wrap_bool b)
let unwrap_bool r = Flat_Runtime.unwrap_bool (record_of_ty_record r)

let none = ty_record_of_record Flat_Runtime.none
let some a = ty_record_of_record (Flat_Runtime.some a)
let unwrap_option r = Flat_Runtime.unwrap_option (record_of_ty_record r)

let dot f r = Flat_Runtime.dot (field_t_of_field f) (record_of_ty_record r)
let dot_opt f r = Flat_Runtime.dot_opt (field_t_of_field f) (record_of_ty_record r)
let unsafe_get i r = Flat_Runtime.unsafe_get i (record_of_ty_record r)

let dot_with_cache cache f r = Flat_Runtime.dot_with_cache cache (field_t_of_field f) (record_of_ty_record r)

let extend_with_array r a =
  ty_record_of_record (Flat_Runtime.extend_with_array (record_of_ty_record r) (Obj.magic a))
external unsafe_init_static : flat_record -> record = "%identity"
let may_be_simple f = ty_record_of_record (Flat_Runtime.may_be_simple f)

let do_exit = ServerLib.do_exit
Something went wrong with that request. Please try again.