Skip to content

GitLab

Commit 1f94d397 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-07-05 13:56:44 by afrisch] Remove old ocaml/cduce interface 

Original author: afrisch
Date: 2004-07-05 13:56:45+00:00
parent 591087ec
Expand all Hide whitespace changes
Inline Side-by-side
cdo2cmo/Makefile deleted 100644 → 0
View file @ 591087ec
# This Makefile generates oCaml_cduce.cmo/.cmx and put it in ..
#
# We need the units such that typing/types.cmo (.cmx)
# - If OCaml has been compiler in a directory DIR,
# you can do:
# make MODEL=tree PREFIX=DIR
# e.g.: make oCaml_cduce.cmo MODEL=tree PREFIX=$HOME/ocaml-3.07
#
# - If you have a (flat) directory DIR will all the compiled units
# from utils/ parsing/ and typing/, you can do:
# make MODEL=flat PREFIX=DIR
# e.g.: make oCaml_cduce.cmo MODEL=fal PREFIX=$HOME/godi/lib/ocaml/compiler-lib
OBJECTS=asttypes.ml $(patsubst %,$(PREFIX)/%, $(UNITS))
XOBJECTS=$(OBJECTS:.cmo=.cmx)
ifeq ($(MODEL),flat)
UNITS= $(subst utils/,,$(UTILS)) \
$(subst parsing/,,$(PARSING)) \
$(subst typing/,,$(TYPING))
INCLUDES = -I $(PREFIX)
else
ifeq ($(MODEL),tree)
UNITS= $(UTILS) $(PARSING) $(TYPING)
INCLUDES = -I $(PREFIX)/utils -I $(PREFIX)/parsing -I $(PREFIX)/typing
else
$(error Set MODEL=flat or MODEL=tree)
endif
endif
oCaml_cduce.cma:
ocamlc -pack -o oCaml_cduce.cmo $(INCLUDES) $(OBJECTS)
mv oCaml_cduce.cmo oCaml_cduce.cmi ..
oCaml_cduce.cmxa:
ocamlopt -pack -o oCaml_cduce.cmx $(INCLUDES) $(XOBJECTS)
mv oCaml_cduce.cmx oCaml_cduce.o oCaml_cduce.cmi ..
clean:
rm -f oCaml_cduce.* *~
UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
utils/clflags.cmo utils/consistbl.cmo
PARSING=parsing/longident.cmo
TYPING=typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \
typing/btype.cmo typing/oprint.cmo \
typing/subst.cmo typing/predef.cmo \
typing/datarepr.cmo typing/env.cmo \
typing/ctype.cmo typing/printtyp.cmo
#UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
# utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
# utils/consistbl.cmo
#
#PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
# parsing/syntaxerr.cmo parsing/parser.cmo \
# parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
#
#TYPING=typing/ident.cmo typing/path.cmo \
# typing/primitive.cmo typing/types.cmo \
# typing/btype.cmo typing/oprint.cmo \
# typing/subst.cmo typing/predef.cmo \
# typing/datarepr.cmo typing/env.cmo \
# typing/typedtree.cmo typing/ctype.cmo \
# typing/printtyp.cmo typing/includeclass.cmo \
# typing/mtype.cmo typing/includecore.cmo \
# typing/includemod.cmo typing/parmatch.cmo \
# typing/typetexp.cmo typing/stypes.cmo typing/typecore.cmo \
# typing/typedecl.cmo typing/typeclass.cmo \
# typing/typemod.cmo
cdo2cmo/asttypes.ml deleted 100644 → 0
View file @ 591087ec
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id: asttypes.ml,v 1.1 2004/06/27 20:52:30 afrisch Exp $ *)
(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
type constant =
Const_int of int
| Const_char of char
| Const_string of string
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
type rec_flag = Nonrecursive | Recursive | Default
type direction_flag = Upto | Downto
type private_flag = Private | Public
type mutable_flag = Immutable | Mutable
type virtual_flag = Virtual | Concrete
type label = string
cdo2cmo/cdml.ml deleted 100644 → 0
View file @ 591087ec
open CDuce_all
type any
type 'a cd2ml = Value.t -> 'a
type 'a ml2cd = 'a -> Value.t
let initialize modname =
let cu = Types.CompUnit.mk ( Ident.U.mk_latin1 modname ) in
try Librarian.import cu; cu
with Librarian.NoImplementation _ ->
failwith ("Cdml: no implementation found for CDuce module " ^ modname)
let identity x = x
let mk_atom s = Value.Atom ( Atoms.V.mk_ascii s )
let atom_to_string v = Ns.QName.to_string ( Atoms.V.value v )
let mk_qname s = Ns.mk_ascii "", Encodings.Utf8.mk s
let record_field map s =
let pool = Ident.LabelPool.mk ( mk_qname s ) in
Ident.LabelMap.assoc pool map
let ocaml2cduce_arrow fa fb f =
let func = fun x -> fb ( f ( fa x ) ) in
Value.Abstraction ( [], func )
let ocaml2cduce_bool = function
| true -> Value.Atom ( Atoms.V.mk_ascii "true" )
| false -> Value.Atom ( Atoms.V.mk_ascii "false" )
let cduce2ocaml_bool = function
| Value.Atom a ->
let v = Ns.QName.to_string ( Atoms.V.value a ) in
compare v "true" = 0
| _ -> assert false
let ocaml2cduce_char c =
let v = Chars.V.mk_char c in Value.Char v
let cduce2ocaml_char = function
| Value.Char c -> Chars.V.to_char c
| _ -> assert false
let ocaml2cduce_int i =
let s = string_of_int i in Value.Integer ( Intervals.V.mk s )
let cduce2ocaml_int = function
| Value.Integer i -> Intervals.V.get_int i
| _ -> assert false
let ocaml2cduce_list f l =
Value.sequence ( List.map f l )
let rec cduce2ocaml_list_aux tail f = function
| Value.Atom _ -> tail
| Value.Pair ( hd, tl ) ->
cduce2ocaml_list_aux ( tail @ [ f hd ] ) f tl
| Value.Concat ( l1, l2 ) ->
cduce2ocaml_list_aux ( cduce2ocaml_list_aux tail f l1 ) f l2
| _ -> assert false
let cduce2ocaml_list f = cduce2ocaml_list_aux [] f
let ocaml2cduce_option f = function
| None -> Value.nil
| Some value -> f value
let cduce2ocaml_option f = function
| Value.Atom v when Ns.QName.to_string ( Atoms.V.value v ) = "nil" -> None
| value -> Some ( f value )
let ocaml2cduce_unit () =
Value.sequence []
let cduce2ocaml_unit = fun _ -> ()
let ocaml2cduce_ref f1 f2 r =
let nget = Ns.mk_ascii "", Encodings.Utf8.mk "get" in
let fget = fun _ -> f1 !r in
let fget = Value.Abstraction ( [], fget ) in
let nset = Ns.mk_ascii "", Encodings.Utf8.mk "set" in
let fset = fun v -> r := f2 v; ocaml2cduce_unit () in
let fset = Value.Abstraction ( [], fset ) in
Value.vrecord [ nget, fget; nset, fset ]
let cduce2ocaml_ref f = function
| _ -> assert false
let ocaml2cduce_string s =
Value.string_latin1 s
let cduce2ocaml_string s =
Value.get_string_latin1 s
let ocaml2cduce_tuple_2 fa fb ( a, b ) =
Value.Pair ( fa a, fb b )
let ocaml2cduce_tuple_3 fa fb fc ( a, b, c ) =
Value.Pair ( fa a, Value.Pair ( fb b, fc c ) )
let ocaml2cduce_tuple_4 fa fb fc fd ( a, b, c, d ) =
Value.Pair ( fa a, Value.Pair ( fb b, Value.Pair ( fc c, fd d ) ) )
let cduce2ocaml_tuple_2 fa fb = function
| Value.Pair ( a, b ) -> fa a, fb b
| _ -> assert false
let cduce2ocaml_tuple_3 fa fb fc = function
| Value.Pair ( a, Value.Pair ( b, c ) ) -> fa a, fb b, fc c
| _ -> assert false
let cduce2ocaml_tuple_4 fa fb fc fd = function
| Value.Pair ( a, Value.Pair ( b, Value.Pair ( c, d ) ) ) ->
fa a, fb b, fc c, fd d
| _ -> assert false
cdo2cmo/cdml.mli deleted 100644 → 0
View file @ 591087ec
(** [any] is the used to represent all CDuce possible values ( = Value.t ). *)
(*
type any
open CDuce_all
type 'a cd2ml = Value.t -> 'a
type 'a ml2cd = 'a -> Value.t
val initialize : string -> Types.CompUnit.t
val identity : Value.t -> Value.t
val mk_atom : string -> Value.t
val atom_to_string : Atoms.V.t -> string
val mk_qname : string -> Ns.qname
val record_field : Value.t Ident.label_map -> string -> Value.t
val ocaml2cduce_arrow : 'a cd2ml -> 'b ml2cd -> ( 'a -> 'b ) -> Value.t
val ocaml2cduce_bool : bool -> Value.t
val cduce2ocaml_bool : Value.t -> bool
val ocaml2cduce_char : char -> Value.t
val cduce2ocaml_char : Value.t -> char
val ocaml2cduce_int : int -> Value.t
val cduce2ocaml_int : Value.t -> int
val ocaml2cduce_list : 'a ml2cd -> 'a list -> Value.t
val cduce2ocaml_list : 'a cd2ml -> Value.t -> 'a list
val ocaml2cduce_option : 'a ml2cd -> 'a option -> Value.t
val cduce2ocaml_option : 'a cd2ml -> Value.t -> 'a option
val ocaml2cduce_ref : 'a ml2cd -> 'a cd2ml -> 'a ref -> Value.t
val cduce2ocaml_ref : 'a cd2ml -> Value.t -> 'a ref
val ocaml2cduce_string : string -> Value.t
val cduce2ocaml_string : Value.t -> string
val ocaml2cduce_tuple_2 : 'a ml2cd -> 'b ml2cd -> 'a * 'b -> Value.t
val ocaml2cduce_tuple_3 : 'a ml2cd -> 'b ml2cd -> 'c ml2cd -> 'a * 'b * 'c -> Value.t
val ocaml2cduce_tuple_4 : 'a ml2cd -> 'b ml2cd -> 'c ml2cd -> 'd ml2cd -> 'a * 'b * 'c * 'd -> Value.t
val cduce2ocaml_tuple_2 : 'a cd2ml -> 'b cd2ml -> Value.t -> 'a * 'b
val cduce2ocaml_tuple_3 : 'a cd2ml -> 'b cd2ml -> 'c cd2ml -> Value.t -> 'a * 'b * 'c
val cduce2ocaml_tuple_4 : 'a cd2ml -> 'b cd2ml -> 'c cd2ml -> 'd cd2ml -> Value.t -> 'a * 'b * 'c * 'd
val ocaml2cduce_unit : unit -> Value.t
val cduce2ocaml_unit : Value.t -> unit
*)
cdo2cmo/ml_cduce.ml deleted 100644 → 0
View file @ 591087ec
open Ml_types
module Translations = struct
type t = cduce_t NodeTbl.t
(* Create an empty table. *)
let create = NodeTbl.create
(* Add a new translation in the table. *)
let add tbl id value = NodeTbl.add tbl id value
(* Get translation associated with [id]. *)
let find tbl id = NodeTbl.find tbl id
end
let translations = Translations.create 17
(***********************************************************************************)
let rec from_ocaml_rec left array = function
| { n_path = id; n_kind = ML_type _; n_decl = decl } ->
Types.descr ( from_ocaml_type left array id decl )
| { n_kind = ML_value; n_decl = decl } ->
from_decl left array decl
| { n_kind = ML_module } -> assert false
and from_ocaml_type left array path decl =
try
Translations.find translations path
with Not_found ->
let node = Types.make () in
Translations.add translations path node;
let desc = from_decl left array decl in
Types.define node desc;
node
and from_decl left array = function
| ML_abstract desc ->
Types.descr ( from_desc left array desc )
| ML_record list ->
let list = List.map (
fun ( name, desc ) ->
let name_ns = Ns.mk_ascii "" in
let name_val = Encodings.Utf8.mk name in
let desc = from_desc left array desc in
( name_ns, name_val ), Types.descr desc
) list in
Types.rec_of_list ~opened:left list
| ML_variant list ->
List.fold_left (
fun t ( name, list ) ->
let node = Types.make () in
let atom = Atoms.atom ( Atoms.V.mk_ascii name ) in
Types.define node ( Types.atom atom );
let desc = match list with
| [] ->
Types.descr node
| hd :: [] ->
let desc = from_desc left array hd in
Types.times node desc
| _ ->
let tuple = variant_of_list left array list in
Types.times node tuple
in
Types.cup t desc
) Types.empty list
| ML_modsign _ -> assert false
| ML_nil -> assert false
and from_desc left array = function
| ML_any -> Types.cons Types.any
| ML_arrow ( lbl, d1, d2 ) ->
let node = Types.make () in
let l = from_desc true array d1
and r = from_desc false array d2 in
Types.define node ( Types.arrow l r );
node
| ML_bool ->
let node = Types.make () in
Types.define node ( Builtin_defs.bool );
node
| ML_char ->
let node = Types.make () in
Types.define node ( Types.char ( Chars.mk_classes [ ( 0, 255 ) ] ) );
node
| ML_ident ( id, params, ocaml ) ->
from_ocaml_type left params ocaml.n_path ocaml.n_decl
| ML_int ->
let node = Types.make () in
let lB = Intervals.V.mk ( string_of_int min_int )
and uB = Intervals.V.mk ( string_of_int max_int ) in
Types.define node ( Types.interval ( Intervals.bounded lB uB ) );
node
| ML_list d ->
let desc = from_desc left array d in
Sequence.star_node desc
| ML_no_manifest -> assert false
| ML_option desc ->
let node = Types.make () in
let trans = Types.descr ( from_desc left array desc ) in
Types.define node ( Types.cup trans Sequence.nil_type );
node
| ML_reference desc ->
let node = Types.make () in
let get = ML_arrow ( None, ML_unit, desc )
and set = ML_arrow ( None, desc, ML_unit ) in
let ref = ML_record [ "get", get ; "set", set ] in
Types.define node ( from_decl false array ref );
node
| ML_string ->
let node = Types.make () in
Types.define node ( Builtin_defs.string_latin1 );
node
| ML_tuple list ->
assert ( List.length list >= 2 );
tuple_of_list left array list
| ML_unit ->
let node = Types.make () in
Types.define node Sequence.nil_type;
node
| ML_var id -> from_desc left array array.( id )
and tuple_of_list left array list =
let rec internal tail = function
| hd :: [] ->
let node = Types.make () in
let desc = from_desc left array hd in
Types.define node ( Types.times desc tail );
node
| hd :: tl ->
let node = Types.make () in
let desc = from_desc left array hd in
Types.define node ( Types.times desc tail );
internal node tl
| [] -> assert false in
let tail = from_desc left array ( List.hd list ) in
internal tail ( List.tl list )
and variant_of_list left array list =
let rec internal tail = function
| hd :: [] ->
let node = Types.make () in
let desc = from_desc left array hd in
Types.define node ( Types.times tail desc );
node
| hd :: tl ->
let node = Types.make () in
let desc = from_desc left array hd in
Types.define node ( Types.times tail desc );
internal node tl
| [] -> assert false in
let tail = from_desc left array ( List.hd list ) in
internal tail ( List.tl list )
(***********************************************************************************)
module Type : sig
type t = cduce_t
val from_ocaml : ocaml_node -> t
val print : Format.formatter -> t -> unit
val is_subtype : t -> t -> bool
end = struct
type t = cduce_t
let from_ocaml ocaml = from_ocaml_rec true [||] ocaml
let print = Types.Print.print
let is_subtype t1 t2 = Types.subtype t1 t2
end
(***********************************************************************************)
module CompUnit : sig
type t
val from_types_cu : string -> Types.CompUnit.t -> t
val from_bytecode : string -> t
val find_type : t -> string -> cduce_t
val find_value : t -> string -> cduce_t
val find_value_slot : t -> string -> int
val module_name : t -> string
end = struct
type t =
{ cu_mod: string;
cu_unit: Types.CompUnit.t;
cu_typer: Typer.t; }
let from_types_cu mod_name cu =
let ty = !( Typer.from_comp_unit ) cu in
{ cu_mod = mod_name; cu_unit = cu; cu_typer = ty }
let from_bytecode file_name =
let mod_name = Filename.chop_suffix file_name ".cdo" in
let cu = Types.CompUnit.mk ( Ident.U.mk_latin1 mod_name ) in
Librarian.import cu;
let ty = !( Typer.from_comp_unit ) cu in
{ cu_mod = mod_name; cu_unit = cu; cu_typer = ty }
let find_type cu name =
let id = Ident.ident ( Ident.U.mk_latin1 name ) in
Typer.find_type id cu.cu_typer
let find_value cu name =
let id = Ident.ident ( Ident.U.mk_latin1 name ) in
Typer.find_value id cu.cu_typer
let find_value_slot cu ( name : string ) =
let cu = cu.cu_unit in
let env = !Compile.from_comp_unit cu in
let id = Ident.ident ( Ident.U.mk_latin1 name ) in
let f_slot = Compile.find id env in
match f_slot with
| Lambda.Ext ( _, i ) -> i
| _ -> assert false
let module_name cu = cu.cu_mod
end;;
cdo2cmo/ml_checker.ml deleted 100644 → 0
View file @ 591087ec
module CD = Ml_cduce
module ML = Ml_ocaml
module Ty = Ml_types
type error =
| Undefined_value of string * string
| Type_mismatch of string * ML.Type.t * CD.Type.t * CD.Type.t
exception Error of error
let error e = raise ( Error e )
let report_error = function
| Undefined_value ( file, func ) ->
Format.eprintf "cduce2ocaml : error in file %s.cmi:@." file;
Format.eprintf "Value %s has no counterpart in file %s.cdo@." func file
| Type_mismatch ( file, ml_t, ml_cd_t, cd_t ) ->
Format.eprintf "cduce2ocaml : error in file %s.cmi:@." file;
CD.Type.print Format.err_formatter cd_t;
Format.eprintf "\nis not a subtype of@.";
CD.Type.print Format.err_formatter ml_cd_t;
Format.eprintf "\nwhich is the canonical translation of@.";
ML.Type.print_declaration Format.err_formatter ml_t
(***********************************************************************************)
let hnode_checker file cduce_cu hnode = match hnode.Ty.h_nodes with
| [ { Ty.n_kind = Ty.ML_value } as caml_type ] ->
begin
let value_name = ML.ptos `Function caml_type.Ty.n_name in
try
let cduce_type = CD.Type.from_ocaml caml_type in
let cduce_base = CD.CompUnit.find_value cduce_cu value_name in
if not ( CD.Type.is_subtype cduce_base cduce_type )
then error ( Type_mismatch ( file, hnode, cduce_type, cduce_base ) );
with Not_found ->
error ( Undefined_value ( file, value_name ) )
end
| _ -> ()
let run caml_cu cduce_cu =
let modname = CD.CompUnit.module_name cduce_cu in
let file = String.copy modname in
String.set file 0 ( Char.lowercase ( String.get modname 0 ) );
try
ML.CompUnit.iter ( hnode_checker file cduce_cu ) caml_cu
with Error e ->
report_error e; exit 1
cdo2cmo/ml_generator.ml deleted 100644 → 0
View file @ 591087ec
This diff is collapsed.
cdo2cmo/ml_ocaml.ml deleted 100644 → 0
View file @ 591087ec
This diff is collapsed.
cdo2cmo/ml_types.ml deleted 100644 → 0
View file @ 591087ec
module ML = OCaml_all
type ocaml_node =
{ mutable n_path: ML.Path.t;
mutable n_name: ML.Path.t;
mutable n_kind: ocaml_kind;
mutable n_decl: ocaml_decl }
and ocaml_kind =
| ML_module
| ML_type of int
| ML_value
and ocaml_decl =
| ML_modsign of ocaml_hypernode list
| ML_nil
| ML_abstract of ocaml_desc
| ML_record of ( string * ocaml_desc ) list
| ML_variant of ( string * ocaml_desc list ) list
and ocaml_desc =
| ML_any
| ML_arrow of string option * ocaml_desc * ocaml_desc
| ML_bool
| ML_char
| ML_ident of ML.Path.t * ocaml_desc array * ocaml_node
| ML_int
| ML_list of ocaml_desc
| ML_no_manifest
| ML_option of ocaml_desc
| ML_reference of ocaml_desc
| ML_string
| ML_tuple of ocaml_desc list
| ML_unit
| ML_var of int
and ocaml_hypernode = { mutable h_nodes: ocaml_node list }
(***********************************************************************************)
module NodeTbl = Hashtbl.Make (
struct
type t = ML.Path.t
let equal = ML.Path.same