Commit 9dd6f30e authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-05-14 10:32:34 by jdemouth] New code generator.

Original author: jdemouth
Date: 2004-05-14 10:32:34+00:00
parent 3cfe74c9
......@@ -2,12 +2,32 @@ 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
Librarian.import cu;
Librarian.run cu;
cu
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" )
......@@ -32,11 +52,68 @@ 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_unit () =
Value.sequence []
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
......@@ -3,8 +3,24 @@ 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
......@@ -17,8 +33,34 @@ 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
......@@ -4,7 +4,7 @@ module Ty = Ml_types
type error =
| Undefined_value of string * string
| Type_mismatch of string * string * ML.Type.t * CD.Type.t * CD.Type.t
| Type_mismatch of string * ML.Type.t * CD.Type.t * CD.Type.t
exception Error of error
......@@ -14,25 +14,25 @@ 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, modname, ml_t, ml_cd_t, cd_t ) ->
| 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 Format.err_formatter modname ml_t
ML.Type.print_declaration Format.err_formatter ml_t
(***********************************************************************************)
let hnode_checker file modname cduce_cu hnode = match hnode.Ty.h_nodes with
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 ( ML.Function modname ) caml_type.Ty.n_name in
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, modname, hnode, cduce_type, cduce_base ) );
then error ( Type_mismatch ( file, hnode, cduce_type, cduce_base ) );
with Not_found ->
error ( Undefined_value ( file, value_name ) )
end
......@@ -43,6 +43,6 @@ let run caml_cu cduce_cu =
let file = String.copy modname in
String.set file 0 ( Char.lowercase ( String.get modname 0 ) );
try
ML.CompUnit.iter ( hnode_checker file modname cduce_cu ) caml_cu
ML.CompUnit.iter ( hnode_checker file cduce_cu ) caml_cu
with Error e ->
report_error e; exit 1
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment