primitive.ml

(**************************************************************************)
(*                                                                        *)
(*                                 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 = Pbigint | Pint32 | Pint64

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_from_constructor: bool; (* Is it from a type constructor instead of a concrete function type? *)
  }

let coerce : (description -> description -> bool) ref = 
  ref (fun 
        (p1 : description) (p2 : description) ->
        p1 = p2
      )

let simple ~name ~arity ~alloc =
  {prim_name = name;
   prim_arity = arity;
   prim_alloc = alloc;
   prim_native_name = "";
   prim_from_constructor = false;}

let make ~name ~alloc ~native_name ~arity =
  {prim_name = name;
   prim_arity = arity;
   prim_alloc = alloc;
   prim_native_name = native_name;
   prim_from_constructor = false;}

let parse_declaration valdecl ~arity ~from_constructor =
  let name, native_name =
    match valdecl.pval_prim with
    | name :: name2 :: _ -> (name, name2)
    | name :: _ -> (name, "")
    | [] ->
        fatal_error "Primitive.parse_declaration"
  in
  {prim_name = name;
   prim_arity = arity;
   prim_alloc = true;
   prim_native_name = native_name;
   prim_from_constructor = from_constructor}

open Outcometree

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
  { osig_val_decl with
    oval_prims = prims;
    oval_attributes = [] }

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